diff --git a/.drom b/.drom index 1f6db902b..112480773 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -2801d121072f91b4400509ce1e5f0b8c:. +4f8f98b9b1774084269015155b53c175:. # end context for . # begin context for .github/workflows/workflow.yml @@ -81,6 +81,7 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project afda02ca8769d29e6d635902a5980764:dune-project +ba662e430c51d699aff2a7eab529f3fa:dune-project # end context for dune-project # begin context for opam/cobol_common.opam @@ -95,7 +96,7 @@ e1fabc309f25556d63d746b1d7451f11:opam/cobol_common.opam # begin context for opam/cobol_data.opam # file opam/cobol_data.opam -60f31e10a5be23cd7161dacee4c7f996:opam/cobol_data.opam +2ac8a5cdac39784c91b3a73a33a5c396:opam/cobol_data.opam # end context for opam/cobol_data.opam # begin context for opam/cobol_indent.opam @@ -300,7 +301,7 @@ bc7d6018a6cdcfb9209efd8d5aeacb95:src/lsp/cobol_config/version.mlt # begin context for src/lsp/cobol_data/dune # file src/lsp/cobol_data/dune -8ec63aca217d7bb803c7538833d3f36a:src/lsp/cobol_data/dune +4c5f42c322869bf815a6afc8a9ebea98:src/lsp/cobol_data/dune # end context for src/lsp/cobol_data/dune # begin context for src/lsp/cobol_data/version.mlt @@ -435,7 +436,7 @@ bc7d6018a6cdcfb9209efd8d5aeacb95:src/lsp/pretty/version.mlt # begin context for src/lsp/superbol-free/linking_flags.sh # file src/lsp/superbol-free/linking_flags.sh -4481ce2bc21d3553716a7914d2cc015a:src/lsp/superbol-free/linking_flags.sh +19b3af846294c26b2c4019ee1ed7e7cf:src/lsp/superbol-free/linking_flags.sh # end context for src/lsp/superbol-free/linking_flags.sh # begin context for src/lsp/superbol_free_lib/dune @@ -480,7 +481,7 @@ b3a1a4662424391d83d94daf0c79756b:src/superbol-studio-oss/dune # begin context for src/vendor/ez_toml/dune # file src/vendor/ez_toml/dune -aad8ac8a26ae15e3501dd5ea3b49ec9a:src/vendor/ez_toml/dune +87fe96c228b8cb51be7268c7e3cdd5b5:src/vendor/ez_toml/dune # end context for src/vendor/ez_toml/dune # begin context for src/vendor/ez_toml/index.mld diff --git a/dune-project b/dune-project index b316012e3..185a05c5d 100644 --- a/dune-project +++ b/dune-project @@ -388,6 +388,7 @@ (description "SuperBOL Studio OSS is a new platform for COBOL") (depends (ocaml (>= 4.14.0)) + (zarith ( >= 1 )) (cobol_ptree (= version)) (cobol_config (= version)) (cobol_common (= version)) diff --git a/opam/cobol_data.opam b/opam/cobol_data.opam index 67a71cd8d..43e17e5ea 100644 --- a/opam/cobol_data.opam +++ b/opam/cobol_data.opam @@ -45,6 +45,7 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "zarith" {>= "1"} "cobol_ptree" {= version} "cobol_config" {= version} "cobol_common" {= version} diff --git a/opam/osx/cobol_data-osx.opam b/opam/osx/cobol_data-osx.opam index 6f4db2c18..75a7610df 100644 --- a/opam/osx/cobol_data-osx.opam +++ b/opam/osx/cobol_data-osx.opam @@ -47,6 +47,7 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "zarith-osx" {>= "1"} "cobol_ptree-osx" {= version} "cobol_config-osx" {= version} "cobol_common-osx" {= version} diff --git a/opam/windows/cobol_data-windows.opam b/opam/windows/cobol_data-windows.opam index e8ef0efa8..0b205bbd1 100644 --- a/opam/windows/cobol_data-windows.opam +++ b/opam/windows/cobol_data-windows.opam @@ -47,6 +47,7 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "zarith-windows" {>= "1"} "cobol_ptree-windows" {= version} "cobol_config-windows" {= version} "cobol_common-windows" {= version} diff --git a/src/lsp/cobol_data/cobol_data.ml b/src/lsp/cobol_data/cobol_data.ml index 27a3e54f6..a7c589e48 100644 --- a/src/lsp/cobol_data/cobol_data.ml +++ b/src/lsp/cobol_data/cobol_data.ml @@ -36,6 +36,7 @@ module Memory = Data_memory module Types = Data_types module Item = Data_item module Picture = Data_picture +module Value = Data_value module Literal = Data_literal module Printer = Data_printer module Visitor = Data_visitor diff --git a/src/lsp/cobol_data/data_diagnostics.ml b/src/lsp/cobol_data/data_diagnostics.ml index 17fbf57f1..f5670077b 100644 --- a/src/lsp/cobol_data/data_diagnostics.ml +++ b/src/lsp/cobol_data/data_diagnostics.ml @@ -21,7 +21,14 @@ type error = max_length: int } (* TODO: +kind *) and invalid_stuff = - | Character_in_boolean_literal of char + | Character_in_literal of { literal_class: literal_class; char: char } + +and literal_class = + | Boolean + | Fixed + | Floating + | Hexadecimal + | Integer and malformed_stuff = | Boolean_literal of string @@ -32,9 +39,22 @@ let error_loc = function | Overlong_literal { loc; _ } -> loc +let pp_literal_class ppf = function + | Boolean -> + Pretty.string ppf "Boolean" + | Fixed -> + Pretty.print ppf "fixed-point@ numeric" + | Floating -> + Pretty.print ppf "floating-point@ numeric" + | Hexadecimal -> + Pretty.string ppf "hexadecimal" + | Integer -> + Pretty.print ppf "Integer" + let pp_invalid_stuff ppf = function - | Character_in_boolean_literal c -> - Pretty.print ppf "character@ `%c'@ in@ Boolean@ literal" c + | Character_in_literal { literal_class; char } -> + Pretty.print ppf "character@ `%c'@ in@ %a@ literal" + char pp_literal_class literal_class let pp_malformed_stuff ppf = function | Boolean_literal _ -> diff --git a/src/lsp/cobol_data/data_literal.ml b/src/lsp/cobol_data/data_literal.ml index 091b1537f..883fb7e66 100644 --- a/src/lsp/cobol_data/data_literal.ml +++ b/src/lsp/cobol_data/data_literal.ml @@ -16,54 +16,124 @@ open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX -type alphanum = - string - [@@deriving show] +module VAL = Data_value +module OUT = Data_diagnostics + +type integer = + { + int_literal: Cobol_ptree.integer; (* option? *) + int_value: VAL.integer; + } + +type fixed = + { + fixed_literal: Cobol_ptree.fixed; (* option? *) + fixed_value: VAL.fixed; + } + +type floating = + { + float_literal: Cobol_ptree.floating; (* option? *) + float_value: VAL.floating; + } + +type alphanum = VAL.alphanum [@@deriving show] type boolean = { - bool_literal: Cobol_ptree.boolean; - bool_value: bool array; (* Please do not mutate! *) + bool_literal: Cobol_ptree.boolean; (* option? *) + bool_value: VAL.boolean; } - [@@deriving show] +[@@deriving show] + +(* --- *) + +let error diags e = OUT.add_error e diags + +let invalid_chars ~loc ~literal_class diags chars = + VAL.NEL.fold_left ~f:begin fun diags (i, c) -> + let loc = Cobol_common.Srcloc.trunc_prefix i loc in + let loc = Cobol_common.Srcloc.prefix 1 loc in + error diags @@ + Invalid { loc; stuff = Character_in_literal { literal_class; char = c } } + end diags chars + +let with_invalid_chars ~loc ~literal_class diags chars v = + let diags = invalid_chars ~loc diags chars ~literal_class in + OUT.result ~diags (v &@ loc) + +(* --- *) + +let pp_integer ppf x = + VAL.pp_integer ppf x.int_value + +let integer ({ payload = literal; loc }: Cobol_ptree.integer with_loc) + : integer with_loc OUT.with_diags = + try + let int_value = VAL.integer_of_string literal in + OUT.result ({ int_literal = literal; int_value } &@ loc) + with VAL.INVALID_CHARS chars -> + with_invalid_chars ~loc OUT.none chars ~literal_class:Integer + { int_literal = literal; int_value = VAL.integer_zero } + +(* --- *) + +let pp_fixed ppf x = + Q.pp_print ppf x.fixed_value + +let fixed ({ payload = literal; loc }: Cobol_ptree.fixed with_loc) + : fixed with_loc OUT.with_diags = + try + let fixed_value = + VAL.fixed_of_strings + ~integral:literal.fixed_integral + ~fractional:literal.fixed_fractional + in + OUT.result ({ fixed_literal = literal; fixed_value } &@ loc) + with VAL.INVALID_CHARS chars -> + with_invalid_chars ~loc OUT.none chars ~literal_class:Fixed + { fixed_literal = literal; fixed_value = VAL.fixed_zero } + +(* --- *) + +let pp_floating ppf x = + VAL.pp_floating ppf x.float_value + +let floating ({ payload = literal; loc }: Cobol_ptree.floating with_loc) + : floating with_loc OUT.with_diags = + try + let float_value = + VAL.floating_of_strings + ~integral:literal.float_significand.fixed_integral + ~fractional:literal.float_significand.fixed_fractional + ~exponent:literal.float_exponent + in + OUT.result ({ float_literal = literal; float_value } &@ loc) + with VAL.INVALID_CHARS chars -> + with_invalid_chars ~loc OUT.none chars ~literal_class:Floating + { float_literal = literal; float_value = VAL.floating_zero } + -let error diags e = Data_diagnostics.add_error e diags +(* --- *) let boolean + (* TODO deal with prefix length? *) ?(max_length = 8_191) (* as per ISO/IEC 1989:2014 *) - Cobol_ptree.{ payload = { bool_base; + Cobol_ptree.{ payload = { bool_base = base; bool_value = literal_string } as bool_literal; loc } = - let diags = Data_diagnostics.none in + let diags = OUT.none in let len = String.length literal_string in let diags = if len > max_length then error diags @@ Overlong_literal { loc; literal_string; max_length } else diags in - match bool_base with - | `Bool -> - let bool_value = Array.make len false in - let _, diags = - Cobol_common.Tokenizing.fold_tokens (literal_string &@ loc) (0, diags) - ~tokenizer:(fun ~loc:_ -> Data_literal_lexer.boolean) - ~until:(function Boolean_done -> true | _ -> false) - ~f:begin fun { payload = b; loc } (i, diags) -> - let diags = - match b with - | Boolean b -> - bool_value.(i) <- b; - diags - | Boolean_invalid c -> - error diags @@ - Invalid { loc; stuff = Character_in_boolean_literal c } - | Boolean_done -> - diags - in - succ i, diags - end - in - Data_diagnostics.result ~diags ({ bool_literal; bool_value } &@ loc) - | `Hex -> - let bool_value = Array.make (len * 4) false in (* TODO: init *) - Data_diagnostics.result ~diags ({ bool_literal; bool_value } &@ loc) + try + let v = { bool_literal; + bool_value = VAL.boolean_of_string ~base literal_string } in + OUT.result ~diags (v &@ loc) + with VAL.INVALID_CHARS chars -> + with_invalid_chars ~loc diags chars + ~literal_class:(if base = `Bool then Boolean else Hexadecimal) + { bool_literal; bool_value = VAL.boolean_zero } diff --git a/src/lsp/cobol_data/data_value.ml b/src/lsp/cobol_data/data_value.ml new file mode 100644 index 000000000..a8ac0746a --- /dev/null +++ b/src/lsp/cobol_data/data_value.ml @@ -0,0 +1,133 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Representation of basic COBOL values. + + `*_of_strings?` functions may raise {!INVALID_CHARS}. *) + +module NEL = Cobol_common.Basics.NEL + +exception INVALID_CHARS of (int * char) NEL.t + +(* Accumulates a non-empty list of characters, associated with their index in a + string [S], and raises {!INVALID_CHARS}. + + The string [S] is given in decomposed form: [specs] is a non-empty list of + tuples [(s, si, f)], that each associates a sub-strings [s] of [S], the index + [si] of its first character in [S], and a predicate [f] that indicates + whether the character [c] of [s] is invalid. + + Important: make sure that at leat one of [f c] holds, for [c] a character of + [s] in a triple [(s, _, f)] given in [specs]. *) +let invalid_chars specs = + let chars = + NEL.of_rev_list @@ List.fold_left begin fun chars (s, si, f) -> + snd @@ String.fold_left begin fun (i, chars) c -> + succ i, if f c then (si + i, c) :: chars else chars + end (0, chars) s + end [] specs + in + raise @@ INVALID_CHARS chars + +let non_digit = function + | '0' .. '9' -> false + | _ -> true + +let non_bool_bit ~base = function + | '0' | '1' -> false + | '2' .. '9' | 'a' .. 'f' | 'A' .. 'F' when base = `Hex -> false + | _ -> true + +(* --- *) + +type integer = Z.t +let integer_zero = Z.zero +let pp_integer = Z.pp_print +let integer_of_string s = + try Z.of_string_base 10 s + with Invalid_argument _ -> + invalid_chars [s, 0, non_digit] + +(* --- *) + +type fixed = Q.t + +let fixed_zero = Q.zero +let pp_fixed = Q.pp_print +let fixed_of_string = Q.of_string +let fixed_of_strings ~integral ~fractional = + try Q.of_string (integral ^ "." ^ fractional) + with Invalid_argument _ -> + invalid_chars [integral, 0, non_digit; + fractional, String.length integral + 1, non_digit] + + +(* --- *) + +type floating = + { + float_significand: fixed; + float_exponent: int; (* 0 <= . <= 9999 in ISO/IEC 2014 *) + } + +let floating_zero = + { + float_significand = Q.zero; + float_exponent = 1; + } + +let pp_floating ppf { float_significand; float_exponent } = + Pretty.print ppf "%aE%d" pp_fixed float_significand float_exponent + +let floating_of_strings ~integral ~fractional ~exponent = + try + { float_significand = Q.of_string (integral ^ "." ^ fractional); + float_exponent = int_of_string exponent } + with Invalid_argument _ -> + let ilen = String.length integral and flen = String.length fractional in + invalid_chars [integral, 0, non_digit; + fractional, ilen + 1, non_digit; + exponent, ilen + flen + 2, non_digit] + +(* --- *) + +type alphanum = + string +[@@deriving show] + +(* --- *) + +type boolean = + { + bool_width: int; (** may be 0 *) + bool_value: Z.t; [@printer Z.pp_print] (** irrelevant if 0-width *) + } +[@@deriving show] + +let boolean_zero = + { + bool_width = 1; + bool_value = integer_zero; + } + +let boolean_of_string ?(base: [`Bool | `Hex] = `Bool) literal = + match literal with + | "" -> + { bool_width = 0; bool_value = Z.zero } + | s -> + let bool_width = String.length s * if base = `Bool then 1 else 4 in + try + let bool_value = Z.of_string_base (if base = `Bool then 2 else 16) s in + { bool_width; bool_value } + with Invalid_argument _ -> + invalid_chars [s, 0, non_bool_bit ~base] diff --git a/src/lsp/cobol_data/dune b/src/lsp/cobol_data/dune index 0c214e56f..511aff742 100644 --- a/src/lsp/cobol_data/dune +++ b/src/lsp/cobol_data/dune @@ -5,7 +5,7 @@ (public_name cobol_data) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries cobol_ptree cobol_config cobol_common ) + (libraries zarith cobol_ptree cobol_config cobol_common ) ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here diff --git a/src/lsp/cobol_data/package.toml b/src/lsp/cobol_data/package.toml index 61ebd0036..79d6cb2dc 100644 --- a/src/lsp/cobol_data/package.toml +++ b/src/lsp/cobol_data/package.toml @@ -56,6 +56,7 @@ skip = ["index.mld"] cobol_common = "version" cobol_config = "version" cobol_ptree = "version" +zarith = ">=1" # package tools dependencies [tools] diff --git a/src/lsp/cobol_lsp/lsp_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index bb08ccfd2..bc37d1b07 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/src/lsp/cobol_lsp/lsp_semtoks.ml @@ -101,15 +101,28 @@ let semtok ?(tokmods = TOKMOD.none) toktyp lexloc = let line = range.start.line in let start = range.start.character in let length = range.end_.character - start in - { line; start; length; toktyp; tokmods } + if length > 0 + then Some { line; start; length; toktyp; tokmods } + else None + +let compare_semtoks first second = + (* Assume lines / chars won't exceed ~ max_int / 2: *) + if first.line = second.line + then first.start - second.start + else first.line - second.line + +let acc_semtok ?(merge = false) s acc = match s with + | None -> acc + | Some s when merge -> List.merge (fun a b -> - compare_semtoks a b) [s] acc + | Some s -> s :: acc let single_line_lexlocs_in ~filename = Srcloc.shallow_single_line_lexlocs_in ~ignore_invalid_filename:true ~filename -let acc_semtoks ~filename ?range ?tokmods toktyp loc acc = +let acc_semtoks ?merge ~filename ?range ?tokmods toktyp loc acc = List.fold_left begin fun acc lexloc -> match range with | Some r when not (Lsp_position.intersects_lexloc r lexloc) -> acc - | _ -> semtok toktyp ?tokmods lexloc :: acc + | _ -> acc_semtok ?merge (semtok toktyp ?tokmods lexloc) acc end acc @@ single_line_lexlocs_in ~filename loc type token_category = @@ -558,7 +571,7 @@ let semtoks_of_comments ~filename ?range rev_comments = Option.fold range ~some:(fun r -> Lsp_position.intersects_lexloc r lexloc) ~none:true -> - semtok TOKTYP.comment lexloc :: acc + acc_semtok (semtok TOKTYP.comment lexloc) acc | _ -> acc end [] @@ -573,7 +586,7 @@ let semtoks_of_ignored ~filename ?range rev_ignored = Option.fold range ~some:(fun r -> Lsp_position.intersects_lexloc r lexloc) ~none:true - then semtok TOKTYP.comment lexloc :: acc + then acc_semtok (semtok TOKTYP.comment lexloc) acc else acc end [] @@ -582,9 +595,9 @@ let semtoks_of_preproc_statements ~filename ?range pplog = | Cobol_preproc.Trace.FileCopy { copyloc = loc; _ } | Cobol_preproc.Trace.Replace { replloc = loc } | Cobol_preproc.Trace.CompilerDirective { loc; _ } -> - acc_semtoks ~filename ?range TOKTYP.macro loc acc + acc_semtoks ~merge:true ~filename ?range TOKTYP.macro loc acc | Cobol_preproc.Trace.Ignored { ignored_loc; _ } -> - acc_semtoks ~filename ?range TOKTYP.comment ignored_loc acc + acc_semtoks ~merge:true ~filename ?range TOKTYP.comment ignored_loc acc | Cobol_preproc.Trace.Replacement _ -> acc end [] (Cobol_preproc.Trace.events pplog) @@ -595,12 +608,9 @@ let semtoks_of_non_ambigious_tokens ~filename ?range tokens = List.rev @@ List.fold_left begin fun acc { payload = token; loc } -> let semtok_infos = match token with | WORD _ | WORD_IN_AREA_A _ -> None - | ALPHANUM _ | ALPHANUM_PREFIX _ -> + | ALPHANUM _ | ALPHANUM_PREFIX _ | NATLIT _ -> Some (TOKTYP.string, TOKMOD.none) - | BOOLIT _ - | NATLIT _ | SINTLIT _ - | FIXEDLIT _ | FLOATLIT _ - | DIGITS _ + | BOOLIT _ | SINTLIT _ | FIXEDLIT _ | FLOATLIT _ | DIGITS _ | EIGHTY_EIGHT -> Some (TOKTYP.number, TOKMOD.none) | PICTURE_STRING _ -> @@ -622,12 +632,6 @@ let semtoks_of_non_ambigious_tokens ~filename ?range tokens = acc_semtoks ~filename ?range ~tokmods toktyp loc acc end [] tokens -let compare_semtoks first second = - let cmp = Stdlib.compare first.line second.line in - if cmp = 0 - then Stdlib.compare first.start second.start - else cmp - let relative_semtoks semtoks = let data = Array.make (5 * List.length semtoks) 0 in ignore @@ List.fold_left begin fun (i, prev_line, prev_start) semtok -> diff --git a/src/lsp/cobol_parser/grammar.mly b/src/lsp/cobol_parser/grammar.mly index ec59ffe4b..bb3090faf 100644 --- a/src/lsp/cobol_parser/grammar.mly +++ b/src/lsp/cobol_parser/grammar.mly @@ -2297,8 +2297,7 @@ let ident_or_literal | i = ident; %prec lowest { UPCAST.ident_with_literal i } | l = literal; { UPCAST.literal_with_ident l } -let figurative_constant [@recovery Zero] - [@symbol ""] := +let figurative_constant [@recovery Zero] [@symbol ""] := | ~ = figurative_constant_no_all; < > | ALL; l = nonnumeric_literal_no_all; { All l } (*ALL symbolic-character (alphanum, national) (defined in SPECIAL-NAMES)*) @@ -2312,8 +2311,7 @@ let figurative_constant_no_all == (* | i = ident { Symbolic i } *) (*conflict in ident_or_xxx_literal*) let integers := ~ = rnel(integer); < > -let integer [@recovery "0"] - [@symbol ""] := +let integer [@recovery integer_zero] [@symbol ""] := | ~ = DIGITS; < > | ~ = SINTLIT; < > | EIGHTY_EIGHT; {"88"} @@ -2329,7 +2327,7 @@ let floatlit [@recovery floating_zero] [@cost 10] let alphanum [@recovery dummy_alphanum] [@symbol ""] := | ~ = ALPHANUM; < > -let literal [@recovery Integer "0"] [@symbol ""] := +let literal [@recovery dummy_literal] [@symbol ""] := | a = alphanum; {Alphanum a} | n = NATLIT; {National n} | b = BOOLIT; {Boolean b} diff --git a/src/lsp/cobol_parser/grammar_tokens.mly b/src/lsp/cobol_parser/grammar_tokens.mly index fd4d13b5e..01fb35eb8 100644 --- a/src/lsp/cobol_parser/grammar_tokens.mly +++ b/src/lsp/cobol_parser/grammar_tokens.mly @@ -10,31 +10,23 @@ (**************************************************************************) %} -%[@recovery.header - let fixed_zero = Cobol_ptree.{ fixed_integer = "0"; - fixed_fractional = "0" } - - let floating_zero = Cobol_ptree.{ float_significand = fixed_zero; - float_exponent = "1" } - - let boolean_zero = Cobol_ptree.{ bool_base = `Bool; - bool_value = "0" } -] +(* Note: `grammar.mly` opens `Cobol_ptree.Dummies`, so it's be openned in + [@recovery] attributes below. *) %token EOF -%token WORD [@recovery "_"] (* [@symbol ""] *) -%token WORD_IN_AREA_A [@recovery "_"] (* [@symbol ""] *) -%token INFO_WORD [@recovery "_"] -%token COMMENT_ENTRY [@recovery ["_"]] +%token WORD [@recovery alphanum__] (* [@symbol ""] *) +%token WORD_IN_AREA_A [@recovery alphanum__] (* [@symbol ""] *) +%token INFO_WORD [@recovery alphanum__] +%token COMMENT_ENTRY [@recovery [alphanum__]] %token ALPHANUM %token ALPHANUM_PREFIX %token BOOLIT [@recovery boolean_zero] -%token NATLIT [@recovery "_"] -%token SINTLIT [@recovery "0"] +%token NATLIT [@recovery alphanum__] +%token SINTLIT [@recovery integer_zero] %token FIXEDLIT [@recovery "0", '.', "0"] %token FLOATLIT [@recovery "0", '.', "0", "1"] -%token DIGITS [@recovery "0"] (* keep as string until resolved as level/intlit *) +%token DIGITS [@recovery integer_zero] %token PICTURE_STRING [@recovery "X"] (* picture character string *) %token EXEC_BLOCK diff --git a/src/lsp/cobol_preproc/compdir_grammar.mly b/src/lsp/cobol_preproc/compdir_grammar.mly index e68fc270a..95adeb4fa 100644 --- a/src/lsp/cobol_preproc/compdir_grammar.mly +++ b/src/lsp/cobol_preproc/compdir_grammar.mly @@ -17,16 +17,28 @@ %token EOL %token TEXT_WORD -%token ALPHANUM -%token BOOLIT - -%token CDIR_DEFINE [@keyword ">>DEFINE", "$DEFINE"] -%token CDIR_ELIF [@keyword ">>ELIF", ">>ELSE-IF"] -%token CDIR_ELSE [@keyword ">>ELSE"] -%token CDIR_END_IF [@keyword ">>END-IF"] -%token CDIR_IF [@keyword ">>IF"] +%token ALPHANUM +%token BOOLLIT +%token FIXEDLIT + +(* Note: use the lexer to distinguish punctuation *) +%token EQ "=" [@keyword (* symbol *) "="] +%token GE ">=" [@keyword (* symbol *) ">="] +%token GT ">" [@keyword (* symbol *) ">"] +%token LE "<=" [@keyword (* symbol *) "<="] +%token LT "<" [@keyword (* symbol *) "<"] +%token NE "<>" [@keyword (* symbol *) "<>"] + +%token CDIR_DEFINE [@keyword ">>DEFINE"] +%token CDIR_ELIF [@keyword ">>ELIF", "$ELIF" (* GC extensions *) + , ">>ELSE-IF", "$ELSE-IF"] +%token CDIR_ELSE [@keyword ">>ELSE", "$ELSE"] +%token CDIR_END [@keyword "$END"] (* Note: no `>>END` equivalent *) +%token CDIR_END_IF [@keyword ">>END-IF" + , "$END-IF"] (* <- undocumented, but found *) +%token CDIR_IF [@keyword ">>IF", "$IF"] %token CDIR_SET [@keyword ">>SET", "$SET"] -%token CDIR_SOURCE [@keyword ">>SOURCE", "$SOURCE"] +%token CDIR_SOURCE [@keyword ">>SOURCE"] %token ADDRSV [@keyword "ADDRSV", "ADD-RSV"] %token ADDSYN [@keyword "ADDSYN", "ADD-SYN"] @@ -65,7 +77,7 @@ %token PARAMETER [@keyword] %token REMOVE [@keyword] %token SET [@keyword] -%token SOURCEFORMAT [@keyword] +%token SOURCEFORMAT [@keyword "SOURCEFORMAT", "SOURCE-FORMAT"] %token SPZERO [@keyword] %token SSRANGE [@keyword] %token THAN [@keyword] @@ -100,6 +112,7 @@ let compiler_directive := | CDIR_IF; ~ = if_directive; | CDIR_ELIF; ~ = elif_directive; | CDIR_ELSE; EOL; { Preproc Else } + | CDIR_END; EOL; { Preproc End } | CDIR_END_IF; EOL; { Preproc End_if } (* --- >>SOURCE | $ SET SOURCEFORMAT ---------------------------------------- *) @@ -158,15 +171,16 @@ let define_directive := | ~ = define; EOL; < > let define := - | w = text_word; AS?; OFF; - { Define_off w } + | ~ = var; AS?; OFF; - | var = text_word; AS?; expr = loc(define_expr); o = bo(OVERRIDE); - { Define { var; expr; override = o } } + | var = var; AS?; value = loc(define_expr); o = bo(OVERRIDE); + { Define { var; value; override = o } } let define_expr := - | ~ = loc(ALPHANUM); - | PARAMETER; {Parameter} + | x = loc(ALPHANUM); {Literal_definition (Alphanum x)} + | x = loc(BOOLLIT); {Literal_definition (Boolean x)} + | x = loc(FIXEDLIT); {Literal_definition (Numeric x)} + | PARAMETER; {Parameter_definition} (* --- >>IF ... ------------------------------------------------------------- *) @@ -185,15 +199,47 @@ let elif := { Elif c } let boolexpr := - | ~ = loc(BOOLIT); - | var = text_word; IS?; neg_polarity = ibo(NOT); DEFINED; + | var = var; IS?; neg_polarity = ibo(NOT); DEFINED; { Defined_condition { var; polarity = not neg_polarity } } + | neg_polarity = ibo(NOT); var = var; + { Value_condition { var; polarity = not neg_polarity } } + | var = var; IS?; neg_polarity = ibo(NOT); o = condition_operator; r = term; + { Constant_condition { left_operand = Variable var; right_operand = r; + polarity = not neg_polarity; operator = o } } + | l = literal; IS?; neg_polarity = ibo(NOT); o = condition_operator; r = term; + { Constant_condition { left_operand = Literal l; right_operand = r; + polarity = not neg_polarity; operator = o } } + +let term := + | ~ = var; + | ~ = literal; + +let condition_operator := + | GREATER; THAN?; OR; EQUAL; TO?; {Ge} + | GREATER; THAN?; {Gt} + | LESS; THAN?; OR; EQUAL; TO?; {Le} + | LESS; THAN?; {Lt} + | EQUAL; TO?; {Eq} + | "="; {Eq} + | ">"; {Gt} + | ">="; {Ge} + | "<="; {Le} + | "<"; {Lt} + | "<>"; {Ne} (* --- Misc ----------------------------------------------------------------- *) let text_word == (* text-word with position *) | ~ = loc(TEXT_WORD); < > +let var := + | v = text_word; { Preproc_env.var' v } + +let literal := + | ~ = loc(ALPHANUM); + | ~ = loc(BOOLLIT); + | ~ = loc(FIXEDLIT); + _unused_symbols: | INVALID_ | ADDRSV diff --git a/src/lsp/cobol_preproc/compdir_tree.ml b/src/lsp/cobol_preproc/compdir_tree.ml index c308f31bc..eb53e36fd 100644 --- a/src/lsp/cobol_preproc/compdir_tree.ml +++ b/src/lsp/cobol_preproc/compdir_tree.ml @@ -18,6 +18,7 @@ type directive_kind = | Define_directive | Elif_directive | Else_directive + | End_directive | EndIf_directive | If_directive | Set_directive @@ -29,37 +30,62 @@ type directive = and lexing_directive = | Source_format_is_free of srcloc [@printer fun _ _ -> ()] - | Source_format_is of string with_loc - | Set_sourceformat of string with_loc + | Source_format_is of Cobol_data.Literal.alphanum with_loc + | Set_sourceformat of Cobol_data.Literal.alphanum with_loc and preproc_directive = | Set of set_operand with_loc - | Define_off of string with_loc + | Define_off of var with_loc | Define of definition | If of boolexpr with_loc | Elif of boolexpr with_loc | Else + | End | End_if and definition = { - var: string with_loc; - expr: define_expr with_loc; + var: var with_loc; + value: definition_value with_loc; override: bool; } -and define_expr = - | Alphanum_literal of Cobol_data.Literal.alphanum with_loc - | Parameter +and var = Preproc_env.VAR.t + +and definition_value = + | Literal_definition of literal + | Parameter_definition + +and literal = + | Alphanum of Cobol_data.Literal.alphanum with_loc + | Boolean of Cobol_data.Literal.boolean with_loc + | Numeric of Cobol_data.Literal.fixed with_loc + +and term = + | Variable of var with_loc + | Literal of literal and boolexpr = - | Boolean_literal of Cobol_data.Literal.boolean with_loc + | Constant_condition of + { + left_operand: term; + polarity: bool; (* false for `negative polarity' *) + operator: condition_operator; + right_operand: term; + } + | Value_condition of + { + var: var with_loc; + polarity: bool; + } | Defined_condition of { - var: string with_loc; + var: var with_loc; polarity: bool; (* false for `var NOT DEFINED' *) } +and condition_operator = Eq | Ge | Gt | Le | Lt | Ne + and set_operand = | Add_srv | Add_syn diff --git a/src/lsp/cobol_preproc/preproc_diagnostics.ml b/src/lsp/cobol_preproc/preproc_diagnostics.ml index 49a675cc5..206caff1e 100644 --- a/src/lsp/cobol_preproc/preproc_diagnostics.ml +++ b/src/lsp/cobol_preproc/preproc_diagnostics.ml @@ -165,16 +165,19 @@ let pp_error ppf = function type warning = | Feature_warning of Cobol_config.DIAG.warning | Ignored of { loc: srcloc; item: ignored_item } + | Incompatible of { loc: srcloc; stuff: incompatible_warning_stuff } | Src_warning of Src_diagnostics.warning + | Undefined_warning of { loc: srcloc; stuff: undefined_warning_stuff } + | Unexpected_warning of { loc: srcloc; stuff: unexpected_warning_stuff } | Undefine_of_unknown_env_variable of { loc: srcloc; - var: string with_loc; + var: Preproc_env.var with_loc; } | Redefinition_of_env_variable of { loc: srcloc; - var: string with_loc; + var: Preproc_env.var with_loc; prev_def_loc: Preproc_env.definition_loc; } (* | Compdir_warning of *) @@ -187,11 +190,33 @@ type warning = and ignored_item = | Compiler_directive +and incompatible_warning_stuff = + | Types_in_compdir_condition of + { + left: Preproc_env.value; + right: Preproc_env.value; + } + +and undefined_warning_stuff = + | Variable_in_compdir_condition of + { + var: Preproc_env.var with_loc; + } + +and unexpected_warning_stuff = + | Variable_type_in_compdir_condition of + { + value: Preproc_env.value; + } + let warning_loc = function | Feature_warning w -> Cobol_config.DIAG.warning_loc w | Ignored { loc; _ } + | Incompatible { loc; _ } | Undefine_of_unknown_env_variable { loc; _ } + | Undefined_warning { loc; _ } + | Unexpected_warning { loc; _ } | Redefinition_of_env_variable { loc; _ } -> loc | Src_warning e -> @@ -201,19 +226,39 @@ let pp_ignored_item ppf = function | Compiler_directive -> Pretty.print ppf "compiler@ directive" +let pp_incompatible_warning_stuff ppf = function + | Types_in_compdir_condition _ -> (* TODO: info on types *) + Pretty.print ppf "types@ in@ compiler@ directive@ condition" + +let pp_undefined_warning_stuff ppf = function + | Variable_in_compdir_condition { var; _ } -> + Pretty.print ppf "variable@ `%a'@ in@ compiler@ directive@ condition" + Preproc_env.VAR.pp ~&var + +let pp_unexpected_warning_stuff ppf = function + | Variable_type_in_compdir_condition _ -> + Pretty.print ppf "type@ of@ variable@ in@ compiler@ directive@ condition" + let pp_warning ppf = function | Feature_warning w -> Cobol_config.DIAG.pp_warning ppf w | Ignored { item; _ } -> Pretty.print ppf "Ignored@ %a" pp_ignored_item item + | Incompatible { stuff; _ } -> + Pretty.print ppf "Incompatible@ %a" pp_incompatible_warning_stuff stuff | Src_warning e -> Src_diagnostics.pp_warning ppf e | Undefine_of_unknown_env_variable { var; _ } -> - Pretty.print ppf "DEFINE@ OFF@ of@ %s,@ which@ is@ not@ defined@ (yet)" - ~&var + Pretty.print ppf "DEFINE@ OFF@ of@ %a,@ which@ is@ not@ defined@ (yet)" + Preproc_env.VAR.pp ~&var + | Undefined_warning { stuff; _ } -> + Pretty.print ppf "Undefined@ %a" pp_undefined_warning_stuff stuff + | Unexpected_warning { stuff; _ } -> + Pretty.print ppf "Unexpected@ %a" pp_unexpected_warning_stuff stuff | Redefinition_of_env_variable { var; prev_def_loc; _ } -> - Pretty.print ppf "Redefinition@ of@ %s;@ previous@ definition@ was@ from@ \ - %t" ~&var + Pretty.print ppf "Redefinition@ of@ %a;@ previous@ definition@ was@ from@ \ + %t" + Preproc_env.VAR.pp ~&var (fun ppf -> match prev_def_loc with | Source_location l -> Cobol_common.Srcloc.pp_file_loc ppf l | Process_parameter -> Pretty.print ppf "process@ parameters" diff --git a/src/lsp/cobol_preproc/preproc_engine.ml b/src/lsp/cobol_preproc/preproc_engine.ml index 3a42c2362..0d15f9d91 100644 --- a/src/lsp/cobol_preproc/preproc_engine.ml +++ b/src/lsp/cobol_preproc/preproc_engine.ml @@ -53,7 +53,9 @@ let diags { diags; reader; _ } = Preproc_diagnostics.add_src_diagnostics (Src_reader.diags reader) diags let add_diags lp d = - { lp with diags = Preproc_diagnostics.union d lp.diags } + if d == Preproc_diagnostics.none + then lp + else { lp with diags = Preproc_diagnostics.union d lp.diags } let add_error lp e = { lp with diags = Preproc_diagnostics.add_error e lp.diags } let add_warn lp w = @@ -200,14 +202,14 @@ let rec next_chunk ({ reader; buff; persist = { dialect; _ }; _ } as lp) = next_chunk (apply_compiler_directive lp compdir) | Ok Some (text, compdir, _compdir_text, diags) when not emitting -> let rev_ignored = List.rev_append text lp.rev_ignored in - let lp = add_diags { lp with reader; buff = []; rev_ignored } diags in + let lp = add_diags { lp with reader; rev_ignored } diags in next_chunk (apply_compiler_directive lp compdir) (* ignore text *) | Ok Some (text, compdir, _compdir_text, diags) -> let lp = add_diags { lp with reader; buff = [] } diags in preprocess_line (apply_compiler_directive lp compdir) (buff @ text) | Error (text, _compdir_text, diags) when not emitting -> let rev_ignored = List.rev_append text lp.rev_ignored in - let lp = add_diags { lp with reader; buff = []; rev_ignored } diags in + let lp = add_diags { lp with reader; rev_ignored } diags in next_chunk lp (* ignore text *) | Error (text, _compdir_text, diags) -> let lp = add_diags { lp with reader; buff = [] } diags in @@ -226,39 +228,36 @@ and apply_compiler_directive ({ reader; pplog; _ } as lp) and apply_preproc_directive ({ env; context; _ } as lp) { payload = ppdir; loc } = + let new_env lp { result = env; diags } = + if env != lp.env || diags != Preproc_diagnostics.none + then { lp with env; diags = Preproc_diagnostics.union diags lp.diags } + else lp + and new_context lp { result = context; diags } = + if context != lp.context || diags != Preproc_diagnostics.none + then { lp with context; diags = Preproc_diagnostics.union diags lp.diags } + else lp + in match ppdir with - | Define_off var -> - (match Preproc_logic.on_define_off ~loc var ~env with - | Ok env -> { lp with env } - | Error diag -> add_warn lp diag) + | Define _ | Define_off _ | Set _ + when not (Preproc_logic.emitting lp.context) -> + lp (* ignore *) | Define def -> - (match Preproc_logic.on_define ~loc def ~env with - | Ok env -> { lp with env } - | Error diag -> add_warn lp diag) + new_env lp @@ Preproc_logic.on_define ~loc def ~env + | Define_off var -> + new_env lp @@ Preproc_logic.on_define_off ~loc var ~env | If condition -> - (match Preproc_logic.on_if ~loc ~condition ~env context with - | Ok context -> { lp with context } - | Error diags -> add_diags lp diags) + new_context lp @@ Preproc_logic.on_if ~loc ~condition ~env context | Elif condition -> - (match Preproc_logic.on_elif ~loc ~condition ~env context with - | Ok context -> { lp with context } - | Error diag -> add_error lp diag) + new_context lp @@ Preproc_logic.on_elif ~loc ~condition ~env context | Else -> - (match Preproc_logic.on_else ~loc context with - | Ok context -> { lp with context } - | Error diag -> add_error lp diag) - | End_if -> (* TODO: entry in pplog so we can grab discarded text *) - let lp = match Preproc_logic.on_endif ~loc context with - | Ok context -> { lp with context } - | Error diag -> add_error lp diag - in - if Preproc_logic.emitting lp.context - then match lp.rev_ignored with - | [] -> - lp - | text -> - with_pplog { lp with rev_ignored = [] } - (Preproc_trace.ignored (List.rev text) lp.pplog) + new_context lp @@ Preproc_logic.on_else ~loc context + | End + | End_if -> + let lp = new_context lp @@ Preproc_logic.on_endif ~loc context in + if Preproc_logic.emitting lp.context && lp.rev_ignored <> [] + then { lp with + rev_ignored = []; + pplog = Preproc_trace.ignored (List.rev lp.rev_ignored) lp.pplog } else lp | Set _ -> add_warn lp @@ Ignored { loc; item = Compiler_directive } diff --git a/src/lsp/cobol_preproc/preproc_env.ml b/src/lsp/cobol_preproc/preproc_env.ml index 6e3c9a73c..c5c009fca 100644 --- a/src/lsp/cobol_preproc/preproc_env.ml +++ b/src/lsp/cobol_preproc/preproc_env.ml @@ -12,7 +12,7 @@ (**************************************************************************) open Cobol_common.Srcloc.TYPES -(* open Cobol_common.Srcloc.INFIX *) +open Cobol_common.Srcloc.INFIX (** Utility module that maps any string to a physically unique upper-cased internal representation. *) @@ -20,6 +20,7 @@ module VAR: sig type t val pp: t Pretty.printer val of_string: string -> t + val to_uppercase_string: t -> string val compare: t -> t -> int val equal: t -> t -> bool end = struct @@ -31,6 +32,7 @@ end = struct let s' = String.uppercase_ascii s in try TBL.find tbl s' with Not_found -> TBL.add tbl s' s'; s' + let to_uppercase_string = Fun.id let compare = String.compare let equal = (==) end @@ -39,6 +41,7 @@ module MAP = Map.Make (VAR) module TYPES = struct type env = definition MAP.t + and var = VAR.t and definition = { def_loc: definition_loc; @@ -53,9 +56,11 @@ module TYPES = struct | Process_environment (* | Computed *) and value = - | Boolean of Cobol_data.Literal.boolean with_preproc_loc - | Alphanum of Cobol_data.Literal.alphanum with_preproc_loc + | Alphanum of Cobol_data.Value.alphanum with_preproc_loc + | Boolean of Cobol_data.Value.boolean with_preproc_loc + | Numeric of Cobol_data.Value.fixed with_preproc_loc + exception UNDEFINED of var with_loc exception REDEFINITION of { prev_def_loc: definition_loc } end include TYPES @@ -65,8 +70,9 @@ type t = env (* pretty-printing *) let pp_value ppf = function - | Boolean _ -> Pretty.print ppf "BOOL" | Alphanum s -> Pretty.print ppf "%s" s.pp_payload + | Boolean b -> Pretty.print ppf "%a" Cobol_data.Value.pp_boolean b.pp_payload + | Numeric f -> Pretty.print ppf "%a" Cobol_data.Value.pp_fixed f.pp_payload let pp_definition ppf { def_value; _ } = pp_value ppf def_value @@ -81,23 +87,29 @@ let pp: t Pretty.printer = fun ppf map -> let empty = MAP.empty let var = VAR.of_string +let var' = Cobol_common.Srcloc.locmap var -let mem v = MAP.mem ((* var *) v) +let mem v = MAP.mem v +let mem' v = MAP.mem ~&v (* higher-level operations *) -(* let define_expr: Compdir_tree.define_expr with_loc -> value = fun e -> *) -(* match ~&e with *) -(* | Alphanum_literal l -> *) -(* Alphanum { pp_payload = ~&l; *) -(* pp_loc = Source_location ~@l } *) +let definition_of ~var env : definition = + match MAP.find_opt ~&var env with + | None -> raise @@ UNDEFINED var + | Some value -> value -let define ~def_loc var value ?(override = false) (env: t) : t = - match MAP.find_opt var env with +let define ~loc var value ?(override = false) (env: t) : t = + match MAP.find_opt ~&var env with | Some { def_loc; _ } when not override -> raise @@ REDEFINITION { prev_def_loc = def_loc } | Some _ | None -> - MAP.add var { def_loc; def_value = value } env + MAP.add ~&var { def_loc = Source_location loc; + def_value = value } env + +let define_process_parameter var value (env: t) : t = (* always override *) + MAP.add var { def_loc = Process_parameter; + def_value = value } env let undefine var (env: t) : t = - MAP.remove var env + MAP.remove ~&var env diff --git a/src/lsp/cobol_preproc/preproc_logic.ml b/src/lsp/cobol_preproc/preproc_logic.ml index 60fd47e0c..b98ea480d 100644 --- a/src/lsp/cobol_preproc/preproc_logic.ml +++ b/src/lsp/cobol_preproc/preproc_logic.ml @@ -17,6 +17,9 @@ open Cobol_common.Srcloc.INFIX open Preproc_diagnostics module ENV = Preproc_env +module VAR = ENV.VAR +module NEL = Cobol_common.Basics.NEL +module OUT = Preproc_outputs module TYPES = struct type context = frame list @@ -42,88 +45,210 @@ let emitting: context -> bool = function | [] -> true | If_condition { emitting; _ } :: _ -> emitting + +(* --- *) + + +let err t e = Preproc_diagnostics.add_error e t +let error e = err Preproc_diagnostics.none e +let warn t w = Preproc_diagnostics.add_warning w t +let warning w = warn Preproc_diagnostics.none w + +let undefined ~loc var = + warning @@ Undefine_of_unknown_env_variable { loc; var } + +let redefinition ~loc var ~prev_def_loc = + warning @@ Redefinition_of_env_variable { loc; var; prev_def_loc } + +let unexpected ~loc stuff = + error @@ Unexpected { loc; stuff } + +let warn_unexpected t ~loc stuff = + warn t @@ Unexpected_warning { loc; stuff } + +let warn_undefined t ~loc stuff = + warn t @@ Undefined_warning { loc; stuff } + (* >>DEFINE / >>SET *) -let on_define_off ~loc var ~env = - let var' = ENV.var ~&var in - if ENV.mem var' env - then Ok (ENV.undefine var' env) - else Error (Undefine_of_unknown_env_variable { loc; var }) -let on_define ~loc Compdir_tree.{ var; expr; override } ~env = +let on_define_off ~loc var ~(env: ENV.t) = + if ENV.mem' var env + then OUT.result (ENV.undefine var env) + else OUT.result env ~diags:(undefined ~loc var) + + +let on_define ~loc Compdir_tree.{ var; value; override } ~env = let open struct exception KEEP_UNDEFINED end in try - let def_loc = ENV.Source_location loc in - let value = match ~&expr with - | Alphanum_literal l -> + let value = match ~&value with + | Literal_definition Alphanum l -> ENV.Alphanum { pp_payload = ~&l; pp_loc = Source_location ~@l } - | Parameter -> (* [Sys.getenv] *) - let v = String.uppercase_ascii ~&var in + | Literal_definition Boolean l -> + ENV.Boolean { pp_payload = ~&l.bool_value; + pp_loc = Source_location ~@l } + | Literal_definition Numeric l -> + ENV.Numeric { pp_payload = ~&l.fixed_value; + pp_loc = Source_location ~@l } + | Parameter_definition -> (* [sys.getenv] *) + let v = ENV.VAR.to_uppercase_string ~&var in match Sys.getenv_opt v with | Some value -> ENV.Alphanum { pp_payload = value; pp_loc = Process_environment } | None -> raise KEEP_UNDEFINED in - Ok (ENV.define ~def_loc (ENV.var ~&var) value ~override env) + OUT.result (ENV.define ~loc var value ~override env) with | KEEP_UNDEFINED -> - Ok env + OUT.result env | ENV.REDEFINITION { prev_def_loc } -> - Error (Redefinition_of_env_variable { loc; var; prev_def_loc }) + OUT.result env ~diags:(redefinition ~loc var ~prev_def_loc) + (* Conditionals *) -let eval_boolexpr env: Compdir_tree.boolexpr with_loc -> bool = fun e -> + +let eval_term: Compdir_tree.term -> ENV.t -> ENV.value = fun term env -> + match term with + | Variable var -> + (ENV.definition_of ~var env).def_value + | Literal Alphanum a -> + Alphanum { pp_payload = ~&a; + pp_loc = Source_location ~@a } + | Literal Boolean b -> + Boolean { pp_payload = ~&b.bool_value; + pp_loc = Source_location ~@b } + | Literal Numeric f -> + Numeric { pp_payload = ~&f.fixed_value; + pp_loc = Source_location ~@f } + + +exception TYPE_MISMATCH of ENV.value * ENV.value + + +type matching_operands = + | Alpha of (Cobol_data.Value.alphanum as 'a) * 'a + | Bool of (Cobol_data.Value.boolean as 'b) * 'b + | Num of (Cobol_data.Value.fixed as 'c) * 'c + + +let operands (a: ENV.value) (b: ENV.value) : matching_operands = + match a, b with + | Alphanum a, Alphanum b -> Alpha (a.pp_payload, b.pp_payload) + | Boolean a, Boolean b -> Bool (a.pp_payload, b.pp_payload) + | Numeric a, Numeric b -> Num (a.pp_payload, b.pp_payload) + | a, b -> raise @@ TYPE_MISMATCH (a, b) + + +let eval_condition ~(operator: Compdir_tree.condition_operator) a b = + match operands a b, operator with + | Alpha (a, b), Eq -> a = b + | Alpha (a, b), Ne -> a <> b + | Alpha (a, b), Le + | Alpha (b, a), Ge -> String.compare a b <= 0 + | Alpha (a, b), Lt + | Alpha (b, a), Gt -> String.compare a b < 0 + | Bool (a, b), Eq -> Z.equal a.bool_value b.bool_value + | Bool (a, b), Ne -> not (Z.equal a.bool_value b.bool_value) + | Bool (a, b), Le + | Bool (b, a), Ge -> Z.leq a.bool_value b.bool_value + | Bool (a, b), Lt + | Bool (b, a), Gt -> Z.lt a.bool_value b.bool_value + | Num (a, b), Eq -> Q.equal a b + | Num (a, b), Ne -> not (Q.equal a b) + | Num (a, b), Le + | Num (b, a), Ge -> Q.leq a b + | Num (a, b), Lt + | Num (b, a), Gt -> Q.lt a b + + +let eval_boolexpr env + : Compdir_tree.boolexpr with_loc -> bool OUT.with_diags = fun e -> + let diags = Preproc_diagnostics.none in match ~&e with - | Boolean_literal b -> - if Array.length (~&b).bool_value > 0 - then (~&b).bool_value.(0) - else false (* CHECKME: zero-length Boolean literal? *) | Defined_condition { var; polarity } -> - ENV.mem (ENV.var ~& var) env = polarity + OUT.result (ENV.mem' var env = polarity) + | Value_condition { var; polarity } -> + begin + match (ENV.definition_of ~var env).def_value with + | Boolean b -> + OUT.result (Z.(equal zero) b.pp_payload.bool_value != polarity) + | Alphanum _ | Numeric _ as value -> + let stuff = Variable_type_in_compdir_condition { value } in + OUT.result ~diags:(warn_unexpected diags ~loc:~@e stuff) false + | exception ENV.UNDEFINED var -> + let stuff = Variable_in_compdir_condition { var } in + OUT.result ~diags:(warn_undefined diags ~loc:~@var stuff) false + end + | Constant_condition { left_operand = l; right_operand = r; + polarity; operator } -> + let l = try Ok (eval_term l env) with ENV.UNDEFINED _var -> Error `Undef + and r = try Ok (eval_term r env) with ENV.UNDEFINED _var -> Error `Undef in + begin + try OUT.result @@ match l, r with + | Ok l, Ok r -> eval_condition ~operator l r = polarity + | Error `Undef, Ok _ | Ok _, Error `Undef + | Error `Undef, Error `Undef -> false (* ignore undefined *) + with TYPE_MISMATCH (left, right) -> + let stuff = Types_in_compdir_condition { left; right } in + let diags = warn diags @@ Incompatible { loc = ~@e; stuff } in + OUT.result ~diags false + end + let on_if ~loc:if_loc ~condition ~env context = - let emitting = eval_boolexpr env condition && emitting context in - Ok (If_condition { condition; emitting; if_loc; else_loc = None } :: context) + OUT.map_result (eval_boolexpr env condition) + ~f:(fun cond -> If_condition { condition; emitting = cond && emitting context; + if_loc; else_loc = None } :: context) + -let on_else ~loc = function +let on_else ~loc context : context OUT.with_diags = + match context with | If_condition ({ else_loc = None; _ } as frame) :: parent_ctxt -> let emitting = not frame.emitting && emitting parent_ctxt in - Ok (If_condition { frame with else_loc = Some loc; - emitting } :: parent_ctxt) + OUT.result (If_condition { frame with else_loc = Some loc; + emitting } :: parent_ctxt) | If_condition { else_loc = Some _; if_loc = initial_if_loc; _ } :: _ -> let suggestion = EndIf_compiler_directive_missing { initial_if_loc } in - let stuff = Else_compiler_directive { suggestion = Some suggestion } in - Error (Unexpected { loc; stuff }) + OUT.result context + ~diags:(unexpected ~loc @@ + Else_compiler_directive { suggestion = Some suggestion }) | _ -> - let stuff = Else_compiler_directive { suggestion = None } in - Error (Unexpected { loc; stuff }) + OUT.result context + ~diags:(unexpected ~loc @@ + Else_compiler_directive { suggestion = None }) -let on_elif ~loc ~condition ~env = function + +let on_elif ~loc ~condition ~env context : context OUT.with_diags = + match context with | If_condition ({ else_loc = None; _ } as frame) :: parent_ctxt -> - let emitting = - not frame.emitting - && eval_boolexpr env condition - && emitting parent_ctxt - in - Ok (If_condition { frame with emitting } :: parent_ctxt) + OUT.map_result (eval_boolexpr env condition) + ~f:begin fun cond -> + let emitting = not frame.emitting && cond && emitting parent_ctxt in + If_condition { frame with emitting } :: parent_ctxt + end | If_condition { else_loc = Some _; if_loc = initial_if_loc; _ } :: _ -> let suggestion = EndIf_compiler_directive_missing { initial_if_loc } in - let stuff = Elif_compiler_directive { suggestion = Some suggestion } in - Error (Unexpected { loc; stuff }) + OUT.result context + ~diags:(unexpected ~loc @@ + Elif_compiler_directive { suggestion = Some suggestion }) | _ -> - let stuff = Elif_compiler_directive { suggestion = None } in - Error (Unexpected { loc; stuff }) + OUT.result context + ~diags:(unexpected ~loc @@ + Elif_compiler_directive { suggestion = None }) + -let on_endif ~loc = function +let on_endif ~loc : context -> context OUT.with_diags = function | If_condition _ :: context -> (* pop *) - Ok context - | _ -> - Error (Unexpected { loc; stuff = EndIf_compiler_directive }) + OUT.result context + | context -> + OUT.result context ~diags:(unexpected ~loc EndIf_compiler_directive) + (* Misc. *) + let flush_contexts ~loc : context -> context * diagnostics = let rec flush_context diags = function | [] -> diff --git a/src/lsp/cobol_preproc/src_lexer.mli b/src/lsp/cobol_preproc/src_lexer.mli index 10f7d2f71..4c3f0cd88 100644 --- a/src/lsp/cobol_preproc/src_lexer.mli +++ b/src/lsp/cobol_preproc/src_lexer.mli @@ -25,6 +25,8 @@ val keyword_of_cdtoken: (Compdir_grammar.token, string) Hashtbl.t type cdtoken_component = | CDTok of Compdir_grammar.token + | CDInt of string + | CDFxd of string * char * string | CDEnd val cdtoken: Compdir_tree.directive_kind -> Lexing.lexbuf -> cdtoken_component diff --git a/src/lsp/cobol_preproc/src_lexer.mll b/src/lsp/cobol_preproc/src_lexer.mll index 299daba46..9e53d258a 100644 --- a/src/lsp/cobol_preproc/src_lexer.mll +++ b/src/lsp/cobol_preproc/src_lexer.mll @@ -40,6 +40,8 @@ type cdtoken_component = | CDTok of Compdir_grammar.token + | CDInt of string + | CDFxd of string * char * string | CDEnd exception INVALID_DIRECTIVE_WORD of string @@ -48,6 +50,7 @@ | CDIR_DEFINE -> Define_directive | CDIR_ELIF -> Elif_directive | CDIR_ELSE -> Else_directive + | CDIR_END -> End_directive | CDIR_END_IF -> EndIf_directive | CDIR_IF -> If_directive | CDIR_SET -> Set_directive @@ -84,6 +87,14 @@ SET; THAN; TO; + + (* Note: operators are treated as keywords. *) + EQ; + GE; + GT; + LE; + LT; + NE; ] let set_keywords = @@ -128,6 +139,7 @@ let else_endif_keywords = cdtokens_subset [ CDIR_ELSE; + CDIR_END; CDIR_END_IF; ] @@ -136,6 +148,7 @@ | If_directive | Elif_directive -> conditional_keywords | Else_directive + | End_directive | EndIf_directive -> else_endif_keywords | Set_directive -> set_keywords | Source_directive -> source_keywords @@ -223,7 +236,7 @@ let cdir_char = let cdir_word_suffix = (cdir_char ((cdir_char | '_' | '-') cdir_char*)*)? (* CHECKME: allow empty? *) let cdir_word = - (">>" ' '? cdir_word_suffix) + (">>" ' '* cdir_word_suffix) (* Fixed format *) @@ -425,7 +438,7 @@ and fixed_nominal state } and fixed_cdir_line marker state (* `>>`-prefixed compiler directive *) = parse - | ' '? cdir_word_suffix + | ' '* cdir_word_suffix { Src_lexing.cdir_word ~ktkd:gobble_line ~knom:fixed_nominal ~marker (Src_lexing.flush_continued state) lexbuf @@ -675,14 +688,31 @@ and free_newline_or_eof state } (* Text-word tokenizer (compiler directives) *) -and cdtoken directive = parse +and cdtoken keywords = parse | blanks - { cdtoken directive lexbuf } + { cdtoken keywords lexbuf } | (nonblank+ as s) - { let cdtoken_of_keyword = keywords_for_directive directive in - CDTok (try Hashtbl.find cdtoken_of_keyword (String.uppercase_ascii s) + { CDTok (try Hashtbl.find keywords (String.uppercase_ascii s) + with Not_found -> TEXT_WORD s) } + + | eof + { CDEnd } + +and cdtoken_with_numerics keywords = parse + + | blanks + { cdtoken_with_numerics keywords lexbuf } + + | (sign? digit+ as s) + { CDInt s } + + | (sign? digit* as n) (['.' ','] as sep) (digit+ as d) + { CDFxd (n, sep, d) } + + | (nonblank+ as s) + { CDTok (try Hashtbl.find keywords (String.uppercase_ascii s) with Not_found -> TEXT_WORD s) } | eof @@ -717,4 +747,17 @@ and pptoken = parse | TrmIndic, _ -> acutrm_line s | CBLXIndic, _ -> cobolx_line s | _, FixedWidth _ -> fixed_line s + + let cdtoken: Compdir_tree.directive_kind -> _ = function + (* | Call_directive *) + | Define_directive + | Elif_directive + | Else_directive + | EndIf_directive + | If_directive + (* | On_off/Turn_directive *) + | Source_directive as d -> + cdtoken_with_numerics (keywords_for_directive d) + | d -> + cdtoken (keywords_for_directive d) } diff --git a/src/lsp/cobol_preproc/src_tokenizer.ml b/src/lsp/cobol_preproc/src_tokenizer.ml index 488a2de63..8b7b34887 100644 --- a/src/lsp/cobol_preproc/src_tokenizer.ml +++ b/src/lsp/cobol_preproc/src_tokenizer.ml @@ -16,49 +16,69 @@ open Text.TYPES type 'b supplier = unit -> 'b * Lexing.position * Lexing.position -(** [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 directive_kind - (chstr: text_word Cobol_common.Srcloc.with_loc) acc = +(** [cdtoks_of_word w] translates a COBOL character string [w] into compiler + directive tokens. *) +let cdtoks_of_word directive_kind + (word: text_word Cobol_common.Srcloc.with_loc) acc = let open Compdir_grammar in let ( ~@@ ) t = Cobol_common.Srcloc.as_lexloc ~@t in - match ~&chstr with + let fixedlit f (toks, acc) = + let f = Cobol_data.Literal.fixed f in + List.cons (FIXEDLIT ~&(f.result), ~@@(f.result)) toks, + Preproc_diagnostics.add_literal_diagnostics f.diags acc + and boollit ~prefix_length ~base str = + let l = Cobol_ptree.boolean_of_string ~base str in + (* CHECKME: remove prefix & quotes from literal location here? *) + let lloc = Cobol_common.Srcloc.trunc_prefix (prefix_length + 1) ~@word in + let lloc = Cobol_common.Srcloc.trunc_suffix 1 lloc in + let b = Cobol_data.Literal.boolean (l &@ lloc) in + [BOOLLIT ~&(b.result), ~@@word], + Preproc_diagnostics.add_literal_diagnostics b.diags acc + in + let lexer = Src_lexer.cdtoken directive_kind in + match ~&word with | CDirWord w | TextWord w -> - List.rev @@ Cobol_common.Tokenizing.fold_tokens (w &@<- chstr) [] - ~tokenizer:(fun ~loc:_ -> Src_lexer.cdtoken directive_kind) - ~until:(function CDEnd -> true | _ -> false) - ~f:begin fun t -> match ~&t with - | CDEnd -> Fun.id - | CDTok tok -> List.cons (tok, ~@@t) - end, - acc + let toks, acc = + Cobol_common.Tokenizing.fold_tokens (w &@<- word) ([], acc) + ~tokenizer:(fun ~loc:_ -> lexer) + ~until:(function CDEnd -> true | _ -> false) + ~f:begin fun t -> match ~&t with + | CDEnd -> + Fun.id + | CDInt s -> + fixedlit (Cobol_ptree.fixed_of_strings s "1" &@<- t) + | CDFxd (n, _, f) -> + fixedlit (Cobol_ptree.fixed_of_strings n f &@<- t) + | CDTok tok -> + fun (toks, acc) -> List.cons (tok, ~@@t) toks, acc + end + in + List.rev toks, acc | Alphanum { knd = Basic; str; qte = _ } -> - [ALPHANUM str, ~@@chstr], + [ALPHANUM str, ~@@word], acc | Alphanum { knd = Bool; str; qte = _ } -> - let l = Cobol_ptree.boolean_of_string ~base:`Bool str in - let b = Cobol_data.Literal.boolean (l &@<- chstr) in - [BOOLIT ~&(b.result), ~@@chstr], - Preproc_diagnostics.add_literal_diagnostics b.diags acc + boollit ~prefix_length:1 ~base:`Bool str + | Alphanum { knd = BoolX; str; qte = _ } -> + boollit ~prefix_length:2 ~base:`Hex str | Eof -> - [EOL, ~@@chstr], acc + [EOL, ~@@word], acc | Pseudo _ | ExecBlock _ | Alphanum _ | AlphanumPrefix _ -> - [INVALID_ ~&chstr, ~@@chstr], acc + [INVALID_ ~&word, ~@@word], acc -(** [pptoks_of_chstr w] translates a COBOL character string [w] into +(** [pptoks_of_word 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. *) -let pptoks_of_chstr (chstr: text_word Cobol_common.Srcloc.with_loc) acc = +let pptoks_of_word (word: text_word Cobol_common.Srcloc.with_loc) acc = let open Preproc_tokens in - let pptok = match ~&chstr with + let pptok = match ~&word with | CDirWord w | TextWord w - -> List.rev @@ Cobol_common.Tokenizing.fold_tokens (w &@<- chstr) [] + -> List.rev @@ Cobol_common.Tokenizing.fold_tokens (w &@<- word) [] ~tokenizer:(fun ~loc:_ -> Src_lexer.pptoken) ~until:(function PPEnd -> true | _ -> false) ~f:begin fun t -> match ~&t with @@ -66,23 +86,23 @@ let pptoks_of_chstr (chstr: text_word Cobol_common.Srcloc.with_loc) acc = | PPTok tok -> List.cons (tok &@<- t) end | Alphanum { knd = Basic; str; qte; _ } - -> [ALPHANUM (str, qte) &@<- chstr] + -> [ALPHANUM (str, qte) &@<- word] | Alphanum { knd = National | NationalX; str; _ } - -> [NATLIT str &@<- chstr] + -> [NATLIT str &@<- word] | Alphanum { knd = Bool | BoolX; str; _ } - -> [BOOLIT str &@<- chstr] + -> [BOOLIT str &@<- word] | Alphanum { knd = Hex; str; _ } - -> [HEXLIT str &@<- chstr] + -> [HEXLIT str &@<- word] | Alphanum { knd = NullTerm; str; _ } - -> [NULLIT str &@<- chstr] + -> [NULLIT str &@<- word] | AlphanumPrefix { str; qte; _ } - -> [ALPHANUM_PREFIX (str, qte) &@<- chstr] + -> [ALPHANUM_PREFIX (str, qte) &@<- word] | Pseudo p - -> [PSEUDO_TEXT p &@<- chstr] + -> [PSEUDO_TEXT p &@<- word] | ExecBlock text - -> [EXEC_BLOCK text &@<- chstr] + -> [EXEC_BLOCK text &@<- word] | Eof - -> [EOL &@<- chstr] + -> [EOL &@<- word] in pptok, acc @@ -115,7 +135,7 @@ let ondemand_list_supplier ~decompose ~endlimit ~pp ~eoi l acc = let cdtoks_of_text_supplier directive_kind text = ondemand_list_supplier text Preproc_diagnostics.none ~eoi:Compdir_grammar.EOL - ~pp:(cdtoks_of_chstr directive_kind) + ~pp:(cdtoks_of_word directive_kind) ~decompose:(fun (y, (s, e)) -> y, s, e) ~endlimit:(fun () -> Lexing.dummy_pos) @@ -124,7 +144,7 @@ let pptoks_of_text_supplier (module Om: Src_overlay.MANAGER) text = let prev_limit = ref None in fst @@ ondemand_list_supplier text () ~eoi:Preproc_tokens.EOL - ~pp:pptoks_of_chstr + ~pp:pptoks_of_word ~decompose:begin fun y -> let s, e = Om.limits ~@y in Option.iter (fun e -> Om.link_limits e s) !prev_limit; diff --git a/src/lsp/cobol_ptree/numericals.ml b/src/lsp/cobol_ptree/numericals.ml index 819cd03f5..8e1957724 100644 --- a/src/lsp/cobol_ptree/numericals.ml +++ b/src/lsp/cobol_ptree/numericals.ml @@ -15,7 +15,7 @@ type integer = string [@@deriving ord] type fixed = { - fixed_integer: string; (** Integer part *) + fixed_integral: string; (** Integer part *) fixed_fractional: string; (** Fractional part *) } [@@deriving ord] @@ -37,12 +37,12 @@ let pp_integer = Pretty.string let fixed_of_strings i d = { - fixed_integer = i; + fixed_integral = i; fixed_fractional = d; } -let pp_fixed ppf { fixed_integer; fixed_fractional } = - Pretty.print ppf "%s.%s" fixed_integer fixed_fractional +let pp_fixed ppf { fixed_integral; fixed_fractional } = + Pretty.print ppf "%s.%s" fixed_integral fixed_fractional let floating_of_strings i d e = { diff --git a/src/lsp/cobol_ptree/pTree_dummies.ml b/src/lsp/cobol_ptree/pTree_dummies.ml index 3bdde8146..7ea563aa2 100644 --- a/src/lsp/cobol_ptree/pTree_dummies.ml +++ b/src/lsp/cobol_ptree/pTree_dummies.ml @@ -17,10 +17,14 @@ open PTree_types open Cobol_common.Srcloc.INFIX +let integer_zero = "0" +and integer_one = "1" +and alphanum__ = "_" + let dummy_loc = Cobol_common.Srcloc.dummy -let dummy_string = "_" &@ dummy_loc +let dummy_string = alphanum__ &@ dummy_loc let dummy_name = dummy_string @@ -39,9 +43,12 @@ let dummy_qualident = let dummy_ident = QualIdent dummy_qualident +let dummy_literal = + Integer integer_zero + let dummy_alphanum = { - str = "_"; + str = alphanum__; quotation = Double_quote; hexadecimal = false; runtime_repr = Native_bytes; @@ -60,7 +67,27 @@ let dummy_picture = let dummy_picture_locale = { locale_name = None; - locale_size = "0"; + locale_size = integer_zero; + } + +(* --- *) + +let fixed_zero = + { + fixed_integral = integer_zero; + fixed_fractional = integer_one; + } + +let floating_zero = + { + float_significand = fixed_zero; + float_exponent = integer_one; + } + +let boolean_zero = + { + bool_base = `Bool; + bool_value = integer_zero; } (* --- *) diff --git a/src/lsp/cobol_typeck/typeck_clauses.ml b/src/lsp/cobol_typeck/typeck_clauses.ml index 067944574..0d9731f9d 100644 --- a/src/lsp/cobol_typeck/typeck_clauses.ml +++ b/src/lsp/cobol_typeck/typeck_clauses.ml @@ -148,8 +148,8 @@ let display_usage_from_literal: Cobol_ptree.literal -> usage = | Integer i -> let with_sign, digits = detect_sign i in Display (PIC.fixed_numeric ~with_sign digits 0) - | Fixed { fixed_integer; fixed_fractional } -> - let with_sign, int_digits = detect_sign fixed_integer + | Fixed { fixed_integral; fixed_fractional } -> + let with_sign, int_digits = detect_sign fixed_integral and frac_digits = String.length fixed_fractional in Display (PIC.fixed_numeric ~with_sign int_digits frac_digits) | _ -> (* TODO... *) diff --git a/src/lsp/superbol-free/linking_flags.sh b/src/lsp/superbol-free/linking_flags.sh index e19b3a872..28afae8d5 100644 --- a/src/lsp/superbol-free/linking_flags.sh +++ b/src/lsp/superbol-free/linking_flags.sh @@ -47,7 +47,7 @@ case "$1" in linux) case $(. /etc/os-release && echo $ID) in alpine) - COMMON_LIBS="bigstringaf_stubs cstruct_stubs camlstr unix c" + COMMON_LIBS="zarith gmp bigstringaf_stubs cstruct_stubs camlstr unix c" # `m` and `pthread` are built-in musl echo2 '(-noautolink' echo2 ' -cclib -Wl,-Bstatic' @@ -63,7 +63,7 @@ case "$1" in esac ;; macosx) - COMMON_LIBS="camlstr bigstringaf_stubs cstruct_stubs unix" + COMMON_LIBS="zarith ${MACPORTS:-/usr/local/osxcross/macports/pkgs/opt/local}/lib/libgmp.a camlstr bigstringaf_stubs cstruct_stubs unix" # `m` and `pthread` are built-in in libSystem echo2 '(-noautolink' for l in $COMMON_LIBS; do diff --git a/src/lsp/superbol-free/package.toml b/src/lsp/superbol-free/package.toml index 278348c54..54b17406c 100644 --- a/src/lsp/superbol-free/package.toml +++ b/src/lsp/superbol-free/package.toml @@ -72,7 +72,5 @@ superbol_free_lib = "version" # static-clibs = "unix" [fields] dune-flags = "(:standard (:include linking.sexp))" -# static-alpine-clibs = "zarith gmp" -# static-macos-clibs = "zarith ${MACPORTS:-/usr/local/osxcross/macports/pkgs/opt/local}/lib/libgmp.a camlstr" -static-macos-clibs = "camlstr bigstringaf_stubs cstruct_stubs" -static-alpine-clibs = "bigstringaf_stubs cstruct_stubs" +static-macos-clibs = "zarith ${MACPORTS:-/usr/local/osxcross/macports/pkgs/opt/local}/lib/libgmp.a camlstr bigstringaf_stubs cstruct_stubs" +static-alpine-clibs = "zarith gmp bigstringaf_stubs cstruct_stubs" diff --git a/src/lsp/superbol_free_lib/common_args.ml b/src/lsp/superbol_free_lib/common_args.ml index c96b4de74..559aae4ce 100644 --- a/src/lsp/superbol_free_lib/common_args.ml +++ b/src/lsp/superbol_free_lib/common_args.ml @@ -149,11 +149,11 @@ let get () = let var = String.sub definition 0 eqsign and def = String.(sub definition (eqsign + 1) (length definition - eqsign - 1)) in - let var = Cobol_preproc.Env.var var in (* TODO: Check numerics: i.e, no quotes & proper format. *) - Cobol_preproc.Env.define var (Alphanum { pp_payload = def; - pp_loc = Process_parameter }) - env ~override:true ~def_loc:Process_parameter + Cobol_preproc.Env.define_process_parameter + (Cobol_preproc.Env.var var) + (Alphanum { pp_payload = def; + pp_loc = Process_parameter }) env with Not_found -> Pretty.failwith "Invalid argument `%s' given to flag `-D`" definition end !definitions Cobol_preproc.Env.empty diff --git a/src/vendor/ez_toml/dune b/src/vendor/ez_toml/dune index ae93cc418..d5ace455e 100644 --- a/src/vendor/ez_toml/dune +++ b/src/vendor/ez_toml/dune @@ -13,8 +13,8 @@ ) -(ocamllex internal_lexer) (menhir (modules internal_parser)) +(ocamllex internal_lexer) (rule (targets version.ml) diff --git a/test/cobol_preprocessing/compiler_directives.ml b/test/cobol_preprocessing/compiler_directives.ml index 31e4c5d3b..e6c5b608b 100644 --- a/test/cobol_preprocessing/compiler_directives.ml +++ b/test/cobol_preprocessing/compiler_directives.ml @@ -34,7 +34,7 @@ let%expect_test "hybrid-format-cdirs" = >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment -$ Source format free +>> Source format free *> another floating comment >> SET SOURCEFORMAT "FIXED" * fixed comment @@ -42,7 +42,7 @@ $ Source format free / comment line >>SET SOURCEFORMAT "CRT" / still comment line -$ SOURCE IS FREE +>> SOURCE IS FREE *> ok let's terminate here |}; [%expect {||}];; @@ -54,7 +54,7 @@ let%expect_test "malformed-cdirs" = >> >>*> empty one? $*> another empty one? - $ SOURCE IS FREE + >> SOURCE IS FREE >> ? $ |}; diff --git a/test/cobol_preprocessing/source_lines.ml b/test/cobol_preprocessing/source_lines.ml index bf6df04fb..487fdc62a 100644 --- a/test/cobol_preprocessing/source_lines.ml +++ b/test/cobol_preprocessing/source_lines.ml @@ -30,7 +30,7 @@ let%expect_test "hybrid-format-cdirs" = >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment -$ Source format free +>> Source format free *> another floating comment >> SET SOURCEFORMAT "FIXED" * fixed comment @@ -38,7 +38,7 @@ $ Source format free / comment line >>SET SOURCEFORMAT "CRT" / still comment line -$ SOURCE IS FREE +>> SOURCE IS FREE *> ok let's terminate here . |}; @@ -48,7 +48,7 @@ $ SOURCE IS FREE >>SET SOURCEFORMAT "COBOLX" - $Source format free + >>Source format free >>SET SOURCEFORMAT "FIXED" @@ -56,7 +56,7 @@ $ SOURCE IS FREE >>SET SOURCEFORMAT "CRT" - $SOURCE IS FREE + >>SOURCE IS FREE . |}];; @@ -70,7 +70,7 @@ let%expect_test "hybrid-format-cdirs-with-cdir-markers" = >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment -$ Source format free +>> Source format free *> another floating comment >> SET SOURCEFORMAT "FIXED" * fixed comment @@ -78,7 +78,7 @@ $ Source format free / comment line >>SET SOURCEFORMAT "CRT" / still comment line -$ SOURCE IS FREE +>> SOURCE IS FREE *> ok let's terminate here . |}; @@ -92,7 +92,7 @@ $ SOURCE IS FREE 4: |new source format| 5: 6: - 7: $Source format free + 7: >>Source format free 7: |new source format| 8: 9: >>SET SOURCEFORMAT "FIXED" @@ -104,7 +104,7 @@ $ SOURCE IS FREE 13: >>SET SOURCEFORMAT "CRT" 13: |new source format| 14: - 15: $SOURCE IS FREE + 15: >>SOURCE IS FREE 15: |new source format| 16: 17: . @@ -120,7 +120,7 @@ let%expect_test "hybrid-format-cdirs-with-cdir-markers-bis" = >> SET SOURCEFORMAT "COBOLX" * comment line *> floating comment -$ Source format free +>> Source format free *> another floating comment >> SET SOURCEFORMAT "FIXED" * fixed comment @@ -128,7 +128,7 @@ $ Source format free / comment line >>SET SOURCEFORMAT "CRT" / still comment line -$ SOURCE IS FREE +>> SOURCE IS FREE *> ok let's terminate here . |}; diff --git a/test/output-tests/listings.expected b/test/output-tests/listings.expected index 18260da47..5bd5fa995 100644 --- a/test/output-tests/listings.expected +++ b/test/output-tests/listings.expected @@ -2984,45 +2984,6 @@ listings.at-2762-prog.cob:34.32-34.41: Considering: import/gnucobol/tests/testsuite.src/listings.at:2848:0 Considering: import/gnucobol/tests/testsuite.src/listings.at:2876:0 -listings.at-2876-prog2.cob:7.6-7.26: - 4 DATA DIVISION. - 5 WORKING-STORAGE SECTION. - 6 PROCEDURE DIVISION. - 7 > $IF ACTIVATE DEFINED ----- ^^^^^^^^^^^^^^^^^^^^ - 8 DISPLAY "NOTOK" NO ADVANCING - 9 END-DISPLAY ->> Error: Invalid $IF compiler directive - -listings.at-2876-prog2.cob:10.6-10.29: - 7 $IF ACTIVATE DEFINED - 8 DISPLAY "NOTOK" NO ADVANCING - 9 END-DISPLAY - 10 > $ELIF ACTIVATE2 DEFINED ----- ^^^^^^^^^^^^^^^^^^^^^^^ - 11 DISPLAY "OK" NO ADVANCING - 12 END-DISPLAY ->> Error: Invalid $ELIF compiler directive - -listings.at-2876-prog2.cob:13.6-13.11: - 10 $ELIF ACTIVATE2 DEFINED - 11 DISPLAY "OK" NO ADVANCING - 12 END-DISPLAY - 13 > $ELSE ----- ^^^^^ - 14 DISPLAY "NOTOK" NO ADVANCING - 15 END-DISPLAY ->> Error: Invalid $ELSE compiler directive - -listings.at-2876-prog2.cob:16.6-16.10: - 13 $ELSE - 14 DISPLAY "NOTOK" NO ADVANCING - 15 END-DISPLAY - 16 > $END ----- ^^^^ - 17 STOP RUN. ->> Error: Invalid $END compiler directive - Considering: import/gnucobol/tests/testsuite.src/listings.at:3684:0 listings.at-3684-expected.lst:1.6-1.7: 1 > GnuCOBOL V.R.P prog.cob diff --git a/test/output-tests/run_functions.expected b/test/output-tests/run_functions.expected index 0143db6e0..3ca80c5c3 100644 --- a/test/output-tests/run_functions.expected +++ b/test/output-tests/run_functions.expected @@ -9,207 +9,7 @@ Considering: import/gnucobol/tests/testsuite.src/run_functions.at:278:0 Considering: import/gnucobol/tests/testsuite.src/run_functions.at:325:0 Considering: import/gnucobol/tests/testsuite.src/run_functions.at:353:0 Considering: import/gnucobol/tests/testsuite.src/run_functions.at:410:0 -run_functions.at-410-prog.cob:19.7-19.31: - 16 SET BITX-FILLER TO TRUE - 17 STRING FUNCTION BIT-OF (TXT) DELIMITED BY SIZE INTO BITX. - 18 *> Discover if running ASCII or EBCDIC - 19 > >>IF CHARSET = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^ - 20 IF BITX NOT = "01001000010010010010111000100000--" - 21 >>ELIF CHARSET = 'EBCDIC' ->> Error: Malformed compiler directive - -run_functions.at-410-prog.cob:21.7-21.32: - 18 *> Discover if running ASCII or EBCDIC - 19 >>IF CHARSET = 'ASCII' - 20 IF BITX NOT = "01001000010010010010111000100000--" - 21 > >>ELIF CHARSET = 'EBCDIC' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^ - 22 IF BITX NOT = "11001000110010010100101101000000--" - 23 >>ELSE ->> Error: Malformed compiler directive - -run_functions.at-410-prog.cob:23.7-23.13: - 20 IF BITX NOT = "01001000010010010010111000100000--" - 21 >>ELIF CHARSET = 'EBCDIC' - 22 IF BITX NOT = "11001000110010010100101101000000--" - 23 > >>ELSE ----- ^^^^^^ - 24 IF 1 = 1 DISPLAY 'CHARSET UNKNOWN! PLEASE REPORT!' - 25 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_functions.at-410-prog.cob:25.7-25.15: - 22 IF BITX NOT = "11001000110010010100101101000000--" - 23 >>ELSE - 24 IF 1 = 1 DISPLAY 'CHARSET UNKNOWN! PLEASE REPORT!' - 25 > >>END-IF ----- ^^^^^^^^ - 26 DISPLAY "UNEXPECTED BIT-VALUE OF 'HI. ': " BITX. - 27 ->> Error: Unexpected >>END-IF compiler directive - -run_functions.at-410-prog.cob:30.7-30.31: - 27 - 28 SET BITX-FILLER TO TRUE - 29 STRING FUNCTION BIT-OF (z"01") DELIMITED BY SIZE INTO BITX. - 30 > >>IF CHARSET = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^ - 31 IF BITX NOT = "001100000011000100000000----------" - 32 >>ELSE ->> Error: Malformed compiler directive - -run_functions.at-410-prog.cob:32.7-32.13: - 29 STRING FUNCTION BIT-OF (z"01") DELIMITED BY SIZE INTO BITX. - 30 >>IF CHARSET = 'ASCII' - 31 IF BITX NOT = "001100000011000100000000----------" - 32 > >>ELSE ----- ^^^^^^ - 33 IF BITX NOT = "111100001111000100000000----------" - 34 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_functions.at-410-prog.cob:34.7-34.15: - 31 IF BITX NOT = "001100000011000100000000----------" - 32 >>ELSE - 33 IF BITX NOT = "111100001111000100000000----------" - 34 > >>END-IF ----- ^^^^^^^^ - 35 - 36 IF FUNCTION BIT-TO-CHAR (BITX(1:24)) NOT = z"01" ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_functions.at:541:0 -run_functions.at-541-prog.cob:36.7-36.31: - 33 SET HEXX-FILLER TO TRUE - 34 STRING FUNCTION HEX-OF (X) DELIMITED BY SIZE INTO HEXX. - 35 *> Discover if running ASCII or EBCDIC - 36 > >>IF CHARSET = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^ - 37 IF HEXX NOT = "20303132--" - 38 >>ELIF CHARSET = 'EBCDIC' ->> Error: Malformed compiler directive - -run_functions.at-541-prog.cob:38.7-38.32: - 35 *> Discover if running ASCII or EBCDIC - 36 >>IF CHARSET = 'ASCII' - 37 IF HEXX NOT = "20303132--" - 38 > >>ELIF CHARSET = 'EBCDIC' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^ - 39 IF HEXX NOT = "40F0F1F2--" - 40 >>ELSE ->> Error: Malformed compiler directive - -run_functions.at-541-prog.cob:40.7-40.13: - 37 IF HEXX NOT = "20303132--" - 38 >>ELIF CHARSET = 'EBCDIC' - 39 IF HEXX NOT = "40F0F1F2--" - 40 > >>ELSE ----- ^^^^^^ - 41 IF 1 = 1 DISPLAY 'CHARSET UNKNOWN! PLEASE REPORT!' - 42 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_functions.at-541-prog.cob:42.7-42.15: - 39 IF HEXX NOT = "40F0F1F2--" - 40 >>ELSE - 41 IF 1 = 1 DISPLAY 'CHARSET UNKNOWN! PLEASE REPORT!' - 42 > >>END-IF ----- ^^^^^^^^ - 43 DISPLAY "UNEXPECTED HEX-VALUE OF '0012': " HEXX. - 44 ->> Error: Unexpected >>END-IF compiler directive - -run_functions.at-541-prog.cob:47.7-47.31: - 44 - 45 SET HEXX-FILLER TO TRUE - 46 STRING FUNCTION HEX-OF (Y) DELIMITED BY SIZE INTO HEXX. - 47 > >>IF CHARSET = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^ - 48 IF HEXX NOT = "48492E20--" - 49 >> ELSE ->> Error: Malformed compiler directive - -run_functions.at-541-prog.cob:49.7-49.14: - 46 STRING FUNCTION HEX-OF (Y) DELIMITED BY SIZE INTO HEXX. - 47 >>IF CHARSET = 'ASCII' - 48 IF HEXX NOT = "48492E20--" - 49 > >> ELSE ----- ^^^^^^^ - 50 IF HEXX NOT = "C8C94B40--" - 51 >> END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_functions.at-541-prog.cob:51.7-51.16: - 48 IF HEXX NOT = "48492E20--" - 49 >> ELSE - 50 IF HEXX NOT = "C8C94B40--" - 51 > >> END-IF ----- ^^^^^^^^^ - 52 DISPLAY "UNEXPECTED HEX-VALUE OF 'HI! ': " HEXX. - 53 ->> Error: Unexpected >>END-IF compiler directive - -run_functions.at-541-prog.cob:66.7-66.31: - 63 - 64 SET HEXX-FILLER TO TRUE - 65 STRING FUNCTION HEX-OF (z"01") DELIMITED BY SIZE INTO HEXX. - 66 > >>IF CHARSET = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^ - 67 IF HEXX NOT = "303100----" - 68 >> ELSE ->> Error: Malformed compiler directive - -run_functions.at-541-prog.cob:68.7-68.14: - 65 STRING FUNCTION HEX-OF (z"01") DELIMITED BY SIZE INTO HEXX. - 66 >>IF CHARSET = 'ASCII' - 67 IF HEXX NOT = "303100----" - 68 > >> ELSE ----- ^^^^^^^ - 69 IF HEXX NOT = "F0F100----" - 70 >> END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_functions.at-541-prog.cob:70.7-70.16: - 67 IF HEXX NOT = "303100----" - 68 >> ELSE - 69 IF HEXX NOT = "F0F100----" - 70 > >> END-IF ----- ^^^^^^^^^ - 71 DISPLAY "UNEXPECTED HEX-VALUE OF z'01': " HEXX. - 72 ->> Error: Unexpected >>END-IF compiler directive - -run_functions.at-541-prog.cob:75.7-75.31: - 72 - 73 SET HEXX-FILLER TO TRUE - 74 STRING FUNCTION HEX-OF (' ') DELIMITED BY SIZE INTO HEXX. - 75 > >>IF CHARSET = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^ - 76 IF HEXX NOT = "20--------" - 77 >> ELSE ->> Error: Malformed compiler directive - -run_functions.at-541-prog.cob:77.7-77.14: - 74 STRING FUNCTION HEX-OF (' ') DELIMITED BY SIZE INTO HEXX. - 75 >>IF CHARSET = 'ASCII' - 76 IF HEXX NOT = "20--------" - 77 > >> ELSE ----- ^^^^^^^ - 78 IF HEXX NOT = "40--------" - 79 >> END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_functions.at-541-prog.cob:79.7-79.16: - 76 IF HEXX NOT = "20--------" - 77 >> ELSE - 78 IF HEXX NOT = "40--------" - 79 > >> END-IF ----- ^^^^^^^^^ - 80 DISPLAY "UNEXPECTED HEX-VALUE OF ' ': " HEXX. - 81 ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_functions.at:575:0 Considering: import/gnucobol/tests/testsuite.src/run_functions.at:650:0 Considering: import/gnucobol/tests/testsuite.src/run_functions.at:685:0 diff --git a/test/output-tests/run_fundamental.expected b/test/output-tests/run_fundamental.expected index 4ac881cc5..9ddea7668 100644 --- a/test/output-tests/run_fundamental.expected +++ b/test/output-tests/run_fundamental.expected @@ -71,36 +71,6 @@ run_fundamental.at-137-dump.c:11.6-11.7: >> Error: Unexpected indicator: `r' Considering: import/gnucobol/tests/testsuite.src/run_fundamental.at:138:0 -run_fundamental.at-138-prog.cob:5.7-5.30: - 2 IDENTIFICATION DIVISION. - 3 PROGRAM-ID. prog. - 4 PROCEDURE DIVISION. - 5 > >>IF CHARSET = 'EBCDIC' ----- ^^^^^^^^^^^^^^^^^^^^^^^ - 6 DISPLAY X"F1F2F3" - 7 >>ELSE ->> Error: Malformed compiler directive - -run_fundamental.at-138-prog.cob:7.7-7.13: - 4 PROCEDURE DIVISION. - 5 >>IF CHARSET = 'EBCDIC' - 6 DISPLAY X"F1F2F3" - 7 > >>ELSE ----- ^^^^^^ - 8 DISPLAY X"313233" - 9 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_fundamental.at-138-prog.cob:9.7-9.15: - 6 DISPLAY X"F1F2F3" - 7 >>ELSE - 8 DISPLAY X"313233" - 9 > >>END-IF ----- ^^^^^^^^ - 10 END-DISPLAY. - 11 CALL "dump" USING X"000102" ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_fundamental.at:179:0 Considering: import/gnucobol/tests/testsuite.src/run_fundamental.at:233:0 Considering: import/gnucobol/tests/testsuite.src/run_fundamental.at:284:0 diff --git a/test/output-tests/run_misc.expected b/test/output-tests/run_misc.expected index 47028dfb0..5499ff0e0 100644 --- a/test/output-tests/run_misc.expected +++ b/test/output-tests/run_misc.expected @@ -607,139 +607,18 @@ run_misc.at-3603-prog2.cob:9.41: >> Hint: Missing IS Considering: import/gnucobol/tests/testsuite.src/run_misc.at:3626:0 -run_misc.at-3626-prog.cob:5.6-5.37: - 2 IDENTIFICATION DIVISION. - 3 PROGRAM-ID. prog. - 4 PROCEDURE DIVISION. - 5 > >>IF EXPECT-ORDER = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - 6 IF "1" NOT < "a" - 7 >>ELIF EXPECT-ORDER = 'EBCDIC' ->> Error: Malformed compiler directive - -run_misc.at-3626-prog.cob:7.6-7.38: - 4 PROCEDURE DIVISION. - 5 >>IF EXPECT-ORDER = 'ASCII' - 6 IF "1" NOT < "a" - 7 > >>ELIF EXPECT-ORDER = 'EBCDIC' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +run_misc.at-3626-prog.cob:11.11-11.17: 8 IF "a" NOT < "1" 9 >>END-IF ->> Error: Malformed compiler directive - -run_misc.at-3626-prog.cob:9.6-9.14: - 6 IF "1" NOT < "a" - 7 >>ELIF EXPECT-ORDER = 'EBCDIC' - 8 IF "a" NOT < "1" - 9 > >>END-IF ----- ^^^^^^^^ 10 DISPLAY "ERROR" END-DISPLAY - 11 END-IF. ->> Error: Unexpected >>END-IF compiler directive + 11 > END-IF. +---- ^^^^^^ + 12 STOP RUN. +>> Error: Invalid syntax Considering: import/gnucobol/tests/testsuite.src/run_misc.at:3663:0 -run_misc.at-3663-prog.cob:12.6-12.37: - 9 03 X PIC X. - 10 PROCEDURE DIVISION. - 11 SORT TBL ASCENDING KEY X. - 12 > >>IF EXPECT-ORDER = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - 13 IF G NOT = "12345abcde" - 14 >>ELIF EXPECT-ORDER = 'EBCDIC' ->> Error: Malformed compiler directive - -run_misc.at-3663-prog.cob:14.6-14.38: - 11 SORT TBL ASCENDING KEY X. - 12 >>IF EXPECT-ORDER = 'ASCII' - 13 IF G NOT = "12345abcde" - 14 > >>ELIF EXPECT-ORDER = 'EBCDIC' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - 15 IF G NOT = "abcde12345" - 16 >>ELSE *> = 'NATIVE' ->> Error: Malformed compiler directive - -run_misc.at-3663-prog.cob:16.6-16.12: - 13 IF G NOT = "12345abcde" - 14 >>ELIF EXPECT-ORDER = 'EBCDIC' - 15 IF G NOT = "abcde12345" - 16 > >>ELSE *> = 'NATIVE' ----- ^^^^^^ - 17 IF NOT G = "12345abcde" OR "abcde12345" - 18 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_misc.at-3663-prog.cob:18.6-18.14: - 15 IF G NOT = "abcde12345" - 16 >>ELSE *> = 'NATIVE' - 17 IF NOT G = "12345abcde" OR "abcde12345" - 18 > >>END-IF ----- ^^^^^^^^ - 19 DISPLAY G END-DISPLAY - 20 END-IF. ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_misc.at:3919:0 -run_misc.at-3919-prog.cob:35.11-35.39: - 32 - 33 PROCEDURE DIVISION. - 34 - 35 > >>IF JUSTIFY EQUAL 'JUSTIFY' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - 36 PERFORM 1000-JUSTIFY-IS-RIGHT THRU 1000-EXIT. - 37 >>ELSE ->> Error: Malformed compiler directive - -run_misc.at-3919-prog.cob:37.11-37.17: - 34 - 35 >>IF JUSTIFY EQUAL 'JUSTIFY' - 36 PERFORM 1000-JUSTIFY-IS-RIGHT THRU 1000-EXIT. - 37 > >>ELSE ----- ^^^^^^ - 38 PERFORM 2000-JUSTIFY-IS-OFF THRU 2000-EXIT. - 39 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - -run_misc.at-3919-prog.cob:39.11-39.19: - 36 PERFORM 1000-JUSTIFY-IS-RIGHT THRU 1000-EXIT. - 37 >>ELSE - 38 PERFORM 2000-JUSTIFY-IS-OFF THRU 2000-EXIT. - 39 > >>END-IF ----- ^^^^^^^^ - 40 - 41 IF ELE4 NOT EQUAL 'RRRRRRRRRR' ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_misc.at:3961:0 -run_misc.at-3961-prog.cob:20.6-20.37: - 17 WHEN K (I) = KK - 18 CONTINUE - 19 END-SEARCH - 20 > >>IF EXPECT-ORDER = 'ASCII' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - 21 IF I NOT = 3 - 22 >>ELIF EXPECT-ORDER = 'EBCDIC' ->> Error: Malformed compiler directive - -run_misc.at-3961-prog.cob:22.6-22.38: - 19 END-SEARCH - 20 >>IF EXPECT-ORDER = 'ASCII' - 21 IF I NOT = 3 - 22 > >>ELIF EXPECT-ORDER = 'EBCDIC' ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - 23 IF I NOT = 8 - 24 >>END-IF ->> Error: Malformed compiler directive - -run_misc.at-3961-prog.cob:24.6-24.14: - 21 IF I NOT = 3 - 22 >>ELIF EXPECT-ORDER = 'EBCDIC' - 23 IF I NOT = 8 - 24 > >>END-IF ----- ^^^^^^^^ - 25 DISPLAY "ERROR" END-DISPLAY - 26 STOP RUN. ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_misc.at:4002:0 Considering: import/gnucobol/tests/testsuite.src/run_misc.at:4037:0 Considering: import/gnucobol/tests/testsuite.src/run_misc.at:4078:0 @@ -5851,16 +5730,6 @@ run_misc.at-12917-prog.cob:21.38-21.43: 23 * >> Error: Invalid syntax -run_misc.at-12917-prog.cob:37.7-37.29: - 34 DISPLAY "ENVPONY was NOT DEFINED;". - 35 >>END-IF - 36 DISPLAY "DPONY set to " CNSPONY ";". - 37 > >>IF ENVPONY = "WHITE" ----- ^^^^^^^^^^^^^^^^^^^^^^ - 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE - 39 >>ELSE ->> Error: Malformed compiler directive - run_misc.at-12917-prog.cob:38.7-38.55: 35 >>END-IF 36 DISPLAY "DPONY set to " CNSPONY ";". @@ -5871,16 +5740,6 @@ run_misc.at-12917-prog.cob:38.7-38.55: 40 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE >> Error: Malformed compiler directive -run_misc.at-12917-prog.cob:39.7-39.13: - 36 DISPLAY "DPONY set to " CNSPONY ";". - 37 >>IF ENVPONY = "WHITE" - 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE - 39 > >>ELSE ----- ^^^^^^ - 40 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE - 41 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - run_misc.at-12917-prog.cob:40.7-40.57: 37 >>IF ENVPONY = "WHITE" 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE @@ -5891,16 +5750,6 @@ run_misc.at-12917-prog.cob:40.7-40.57: 42 DISPLAY "My pony is " PONY ";". >> Error: Malformed compiler directive -run_misc.at-12917-prog.cob:41.7-41.15: - 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE - 39 >>ELSE - 40 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE - 41 > >>END-IF ----- ^^^^^^^^ - 42 DISPLAY "My pony is " PONY ";". - 43 >>IF DPONY IS DEFINED ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_misc.at:12983:0 run_misc.at-12983-prog.cob:5.7-5.35: 2 IDENTIFICATION DIVISION. @@ -5962,16 +5811,6 @@ run_misc.at-12983-prog.cob:21.38-21.43: 23 * >> Error: Invalid syntax -run_misc.at-12983-prog.cob:37.7-37.29: - 34 DISPLAY "ENVPONY was NOT DEFINED;". - 35 >>END-IF - 36 DISPLAY "DPONY set to " CNSPONY ";". - 37 > >>IF ENVPONY = "WHITE" ----- ^^^^^^^^^^^^^^^^^^^^^^ - 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE - 39 >>ELSE ->> Error: Malformed compiler directive - run_misc.at-12983-prog.cob:38.7-38.55: 35 >>END-IF 36 DISPLAY "DPONY set to " CNSPONY ";". @@ -5982,16 +5821,6 @@ run_misc.at-12983-prog.cob:38.7-38.55: 40 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE >> Error: Malformed compiler directive -run_misc.at-12983-prog.cob:39.7-39.13: - 36 DISPLAY "DPONY set to " CNSPONY ";". - 37 >>IF ENVPONY = "WHITE" - 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE - 39 > >>ELSE ----- ^^^^^^ - 40 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE - 41 >>END-IF ->> Error: Unexpected >>ELSE compiler directive - run_misc.at-12983-prog.cob:40.7-40.57: 37 >>IF ENVPONY = "WHITE" 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE @@ -6002,16 +5831,6 @@ run_misc.at-12983-prog.cob:40.7-40.57: 42 DISPLAY "My pony is " PONY ";". >> Error: Malformed compiler directive -run_misc.at-12983-prog.cob:41.7-41.15: - 38 >>DEFINE CONSTANT PONY AS "White Horse" OVERRIDE - 39 >>ELSE - 40 >>DEFINE CONSTANT PONY AS "default Dirty" OVERRIDE - 41 > >>END-IF ----- ^^^^^^^^ - 42 DISPLAY "My pony is " PONY ";". - 43 >>IF DPONY IS DEFINED ->> Error: Unexpected >>END-IF compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_misc.at:13049:0 run_misc.at-13049-prog.cob:14.30-14.31: 11 05 FLD4 PIC X(4). @@ -6244,15 +6063,6 @@ run_misc.at-13049-prog.cob:28.28-28.33: >> Error: Invalid syntax Considering: import/gnucobol/tests/testsuite.src/run_misc.at:13127:0 -run_misc.at-13127-prog.cob:3.7-3.28: - 1 - 2 >>DEFINE MYDOG AS "Piper" - 3 > >>DEFINE MYNUM1 AS 11 ----- ^^^^^^^^^^^^^^^^^^^^^ - 4 IDENTIFICATION DIVISION. - 5 PROGRAM-ID. prog. ->> Error: Malformed compiler directive - run_misc.at-13127-prog.cob:17.35-17.36: 14 01 PICX PIC XXX VALUE 'Abc'. 15 01 CAT CONSTANT 'Cat '. diff --git a/test/output-tests/run_refmod.expected b/test/output-tests/run_refmod.expected index 39614339e..3de82ae64 100644 --- a/test/output-tests/run_refmod.expected +++ b/test/output-tests/run_refmod.expected @@ -58,26 +58,6 @@ run_refmod.at-466-prog2.cob:2.6-2.21: 4 PROGRAM-ID. prog2. >> Error: Malformed compiler directive -run_refmod.at-466-prog2.cob:15.6-15.39: - 12 01 m PIC 9 VALUE 2. - 13 - 14 PROCEDURE DIVISION. - 15 > $IF TEST-ZERO-LEN-REF-MOD DEFINED ----- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - 16 DISPLAY y (1:n) - 17 $END ->> Error: Invalid $IF compiler directive - -run_refmod.at-466-prog2.cob:17.6-17.10: - 14 PROCEDURE DIVISION. - 15 $IF TEST-ZERO-LEN-REF-MOD DEFINED - 16 DISPLAY y (1:n) - 17 > $END ----- ^^^^ - 18 DISPLAY y (1:m) - 19 GOBACK. ->> Error: Invalid $END compiler directive - Considering: import/gnucobol/tests/testsuite.src/run_refmod.at:490:0 run_refmod.at-490-prog3.cob:2.6-2.21: 1 diff --git a/test/output-tests/syn_misc.expected b/test/output-tests/syn_misc.expected index d3cbe3e9e..ef6b0a643 100644 --- a/test/output-tests/syn_misc.expected +++ b/test/output-tests/syn_misc.expected @@ -2401,16 +2401,6 @@ syn_misc.at-6994-prog.cob:8.9-8.35: 10 >> END-IF >> Error: Invalid >>DISPLAY compiler directive -syn_misc.at-6994-prog.cob:9.9-9.22: - 6 >>DISPLAY "X defined" - 7 >> ELSE - 8 >> DISPLAY "X not defined" - 9 > >> DEFINE X 1 ----- ^^^^^^^^^^^^^ - 10 >> END-IF - 11 CONTINUE ->> Error: Malformed compiler directive - Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7027:0 syn_misc.at-7027-prog.cob:8.7-8.49: 5 >>IF A IS DEFINED @@ -2444,16 +2434,6 @@ syn_misc.at-7027-prog.cob:17.7-17.22: Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7051:0 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7109:0 -syn_misc.at-7109-prog.cob:8.6-8.19: - 5 WORKING-STORAGE SECTION. - 6 78 Y VALUE 'a'. - 7 PROCEDURE DIVISION. - 8 > $IF X DEFINED ----- ^^^^^^^^^^^^^ - 9 $DISPLAY X defined - 10 $ELIF Y DEFINED ->> Error: Invalid $IF compiler directive - syn_misc.at-7109-prog.cob:9.6-9.24: 6 78 Y VALUE 'a'. 7 PROCEDURE DIVISION. @@ -2464,16 +2444,6 @@ syn_misc.at-7109-prog.cob:9.6-9.24: 11 $DISPLAY X not defined, but Y via lvl 78 >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7109-prog.cob:10.6-10.21: - 7 PROCEDURE DIVISION. - 8 $IF X DEFINED - 9 $DISPLAY X defined - 10 > $ELIF Y DEFINED ----- ^^^^^^^^^^^^^^^ - 11 $DISPLAY X not defined, but Y via lvl 78 - 12 $ELSE ->> Error: Invalid $ELIF compiler directive - syn_misc.at-7109-prog.cob:11.6-11.46: 8 $IF X DEFINED 9 $DISPLAY X defined @@ -2484,16 +2454,6 @@ syn_misc.at-7109-prog.cob:11.6-11.46: 13 $DISPLAY X not defined >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7109-prog.cob:12.6-12.11: - 9 $DISPLAY X defined - 10 $ELIF Y DEFINED - 11 $DISPLAY X not defined, but Y via lvl 78 - 12 > $ELSE ----- ^^^^^ - 13 $DISPLAY X not defined - 14 $END ->> Error: Invalid $ELSE compiler directive - syn_misc.at-7109-prog.cob:13.6-13.28: 10 $ELIF Y DEFINED 11 $DISPLAY X not defined, but Y via lvl 78 @@ -2504,27 +2464,7 @@ syn_misc.at-7109-prog.cob:13.6-13.28: 15 CONTINUE >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7109-prog.cob:14.6-14.10: - 11 $DISPLAY X not defined, but Y via lvl 78 - 12 $ELSE - 13 $DISPLAY X not defined - 14 > $END ----- ^^^^ - 15 CONTINUE - 16 . ->> Error: Invalid $END compiler directive - Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7160:0 -syn_misc.at-7160-prog.cob:11.6-11.17: - 8 78 X VALUE 2. - 9 78 Z VALUE 354. - 10 PROCEDURE DIVISION. - 11 > $IF Y = Y2X ----- ^^^^^^^^^^^ - 12 $DISPLAY correct Y = Y2 - 13 $ELSE ->> Error: Invalid $IF compiler directive - syn_misc.at-7160-prog.cob:12.6-12.29: 9 78 Z VALUE 354. 10 PROCEDURE DIVISION. @@ -2535,16 +2475,6 @@ syn_misc.at-7160-prog.cob:12.6-12.29: 14 $DISPLAY bad: Y should be = Y2 >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:13.6-13.11: - 10 PROCEDURE DIVISION. - 11 $IF Y = Y2X - 12 $DISPLAY correct Y = Y2 - 13 > $ELSE ----- ^^^^^ - 14 $DISPLAY bad: Y should be = Y2 - 15 $END ->> Error: Invalid $ELSE compiler directive - syn_misc.at-7160-prog.cob:14.6-14.36: 11 $IF Y = Y2X 12 $DISPLAY correct Y = Y2 @@ -2555,26 +2485,6 @@ syn_misc.at-7160-prog.cob:14.6-14.36: 16 $IF Y > X >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:15.6-15.10: - 12 $DISPLAY correct Y = Y2 - 13 $ELSE - 14 $DISPLAY bad: Y should be = Y2 - 15 > $END ----- ^^^^ - 16 $IF Y > X - 17 $DISPLAY BAD - Y is not > X ->> Error: Invalid $END compiler directive - -syn_misc.at-7160-prog.cob:16.6-16.15: - 13 $ELSE - 14 $DISPLAY bad: Y should be = Y2 - 15 $END - 16 > $IF Y > X ----- ^^^^^^^^^ - 17 $DISPLAY BAD - Y is not > X - 18 $ELIF Y < X ->> Error: Invalid $IF compiler directive - syn_misc.at-7160-prog.cob:17.6-17.33: 14 $DISPLAY bad: Y should be = Y2 15 $END @@ -2585,16 +2495,6 @@ syn_misc.at-7160-prog.cob:17.6-17.33: 19 $DISPLAY correct Y < X >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:18.6-18.17: - 15 $END - 16 $IF Y > X - 17 $DISPLAY BAD - Y is not > X - 18 > $ELIF Y < X ----- ^^^^^^^^^^^ - 19 $DISPLAY correct Y < X - 20 $ELSE ->> Error: Invalid $ELIF compiler directive - syn_misc.at-7160-prog.cob:19.6-19.28: 16 $IF Y > X 17 $DISPLAY BAD - Y is not > X @@ -2605,16 +2505,6 @@ syn_misc.at-7160-prog.cob:19.6-19.28: 21 $DISPLAY BROKEN >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:20.6-20.11: - 17 $DISPLAY BAD - Y is not > X - 18 $ELIF Y < X - 19 $DISPLAY correct Y < X - 20 > $ELSE ----- ^^^^^ - 21 $DISPLAY BROKEN - 22 $END ->> Error: Invalid $ELSE compiler directive - syn_misc.at-7160-prog.cob:21.6-21.21: 18 $ELIF Y < X 19 $DISPLAY correct Y < X @@ -2625,26 +2515,6 @@ syn_misc.at-7160-prog.cob:21.6-21.21: 23 >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:22.6-22.10: - 19 $DISPLAY correct Y < X - 20 $ELSE - 21 $DISPLAY BROKEN - 22 > $END ----- ^^^^ - 23 - 24 $IF X > Y ->> Error: Invalid $END compiler directive - -syn_misc.at-7160-prog.cob:24.6-24.15: - 21 $DISPLAY BROKEN - 22 $END - 23 - 24 > $IF X > Y ----- ^^^^^^^^^ - 25 $DISPLAY correct X > Y - 26 $ELIF X < Y ->> Error: Invalid $IF compiler directive - syn_misc.at-7160-prog.cob:25.6-25.28: 22 $END 23 @@ -2655,16 +2525,6 @@ syn_misc.at-7160-prog.cob:25.6-25.28: 27 $DISPLAY BAD - X is not < Y >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:26.6-26.17: - 23 - 24 $IF X > Y - 25 $DISPLAY correct X > Y - 26 > $ELIF X < Y ----- ^^^^^^^^^^^ - 27 $DISPLAY BAD - X is not < Y - 28 $ELSE ->> Error: Invalid $ELIF compiler directive - syn_misc.at-7160-prog.cob:27.6-27.33: 24 $IF X > Y 25 $DISPLAY correct X > Y @@ -2675,16 +2535,6 @@ syn_misc.at-7160-prog.cob:27.6-27.33: 29 $DISPLAY BROKEN >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:28.6-28.11: - 25 $DISPLAY correct X > Y - 26 $ELIF X < Y - 27 $DISPLAY BAD - X is not < Y - 28 > $ELSE ----- ^^^^^ - 29 $DISPLAY BROKEN - 30 $END ->> Error: Invalid $ELSE compiler directive - syn_misc.at-7160-prog.cob:29.6-29.21: 26 $ELIF X < Y 27 $DISPLAY BAD - X is not < Y @@ -2695,16 +2545,6 @@ syn_misc.at-7160-prog.cob:29.6-29.21: 31 CONTINUE >> Error: Invalid $DISPLAY compiler directive -syn_misc.at-7160-prog.cob:30.6-30.10: - 27 $DISPLAY BAD - X is not < Y - 28 $ELSE - 29 $DISPLAY BROKEN - 30 > $END ----- ^^^^ - 31 CONTINUE - 32 . ->> Error: Invalid $END compiler directive - Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7193:0 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7264:0 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:7417:0