diff --git a/src/lsp/cobol_data/data_printer.ml b/src/lsp/cobol_data/data_printer.ml index 717a06b66..ecfebee1e 100644 --- a/src/lsp/cobol_data/data_printer.ml +++ b/src/lsp/cobol_data/data_printer.ml @@ -23,6 +23,7 @@ let pp_int' = Cobol_ptree.pp_with_loc Fmt.int let pp_int'_opt = Fmt.option pp_int' let pp_qualname'_opt = Fmt.option Cobol_ptree.pp_qualname' let pp_literal'_opt = Fmt.option Cobol_ptree.pp_literal' +let pp_literal'_list = Fmt.list Cobol_ptree.pp_literal' let pp_usage: usage Pretty.printer = fun ppf -> function | Usage picture -> @@ -37,6 +38,7 @@ let rec pp_item_definition: item_definition Pretty.printer = fun ppf x -> and item_layout x = x.item_layout and item_offset x = x.item_offset and item_size x = x.item_size + and item_conditions x = x.item_conditions and item_redefinitions x = x.item_redefinitions in Pretty.record_with_conditional_fields [ I ((fun x -> x.item_qualname <> None), @@ -47,6 +49,8 @@ let rec pp_item_definition: item_definition Pretty.printer = fun ppf x -> T (Fmt.field "offset" item_offset pp_offset); T (Fmt.field "size" item_size pp_size); T (Pretty.vfield "layout" item_layout pp_item_layout); + C ((fun x -> x.item_conditions <> []), + Pretty.vfield "conditions" item_conditions pp_condition_names); C ((fun x -> x.item_redefinitions <> []), Pretty.vfield "redefs" item_redefinitions pp_item_redefinitions); ] ppf x @@ -61,38 +65,38 @@ and pp_item_redefinitions: item_redefinitions Pretty.printer = fun ppf -> Fmt.(list ~sep:nop) pp_item_definition' ppf and pp_item_layout: item_layout Pretty.printer = fun ppf -> function - | Elementary_item { usage; value } -> + | Elementary_item { usage; init_value } -> Pretty.record_with_conditional_fields [ T Fmt.(styled `Yellow @@ any "elementary"); T (Pretty.vfield "usage" (fun () -> usage) pp_usage); - C'(value <> None, - Fmt.field "value" (fun () -> value) pp_literal'_opt); + C'(init_value <> None, + Fmt.field "value" (fun () -> init_value) pp_literal'_opt); ] ppf () | Struct_item { fields } -> Pretty.record_with_conditional_fields [ T Fmt.(styled `Yellow @@ const string "structure"); T (Pretty.vfield "fields" Fun.id pp_item_definitions); ] ppf fields - | Fixed_table { items; length; value } -> + | Fixed_table { items; length; init_values } -> Pretty.record_with_conditional_fields [ T Fmt.(styled `Yellow @@ any "fixed-length table"); T (Fmt.field "length" (fun () -> length) pp_int'); T (Pretty.vfield "items" (fun () -> items) pp_item_definitions); - C'(value <> None, - Pretty.vfield "value" (fun () -> value) pp_literal'_opt); + C'(init_values <> [], + Pretty.vfield "value" (fun () -> init_values) pp_literal'_list); ] ppf () - | Depending_table { items; min_occurs; max_occurs; depending; value } -> + | Depending_table { items; min_occurs; max_occurs; depending; init_values } -> Pretty.record_with_conditional_fields [ T Fmt.(styled `Yellow @@ any "variable-length table"); T (Fmt.field "min_occurs" (fun () -> min_occurs) pp_int'); T (Fmt.field "max_occurs" (fun () -> max_occurs) pp_int'); T (Fmt.field "depending" (fun () -> depending) Cobol_ptree.pp_qualname'); T (Pretty.vfield "items" (fun () -> items) pp_item_definitions); - C'(value <> None, - Pretty.vfield "value" (fun () -> value) pp_literal'_opt); + C'(init_values <> [], + Pretty.vfield "value" (fun () -> init_values) pp_literal'_list); ] ppf () | Dynamic_table { items; capacity; min_capacity; max_capacity; initialized; - value } -> + init_values } -> Pretty.record_with_conditional_fields [ T Fmt.(styled `Yellow @@ any "dynamic-length table"); C'(capacity <> None, @@ -103,10 +107,23 @@ and pp_item_layout: item_layout Pretty.printer = fun ppf -> function Fmt.field "max_capacity" (fun () -> max_capacity) pp_int'_opt); C'(~&initialized, Fmt.any "initialized"); T (Pretty.vfield "items" (fun () -> items) pp_item_definitions); - C'(value <> None, - Pretty.vfield "value" (fun () -> value) pp_literal'_opt); + C'(init_values <> [], + Pretty.vfield "value" (fun () -> init_values) pp_literal'_list); ] ppf () +and pp_condition_name: condition_name Pretty.printer = + Pretty.record_with_conditional_fields [ + T (Fmt.field "qualname" (fun r -> r.condition_name_qualname) + Cobol_ptree.pp_qualname'); + T (Fmt.field "values" (fun _ -> "...") Fmt.string); + ] + +and pp_condition_name': condition_name with_loc Pretty.printer = fun ppf -> + Cobol_ptree.pp_with_loc pp_condition_name ppf + +and pp_condition_names: condition_names Pretty.printer = fun ppf -> + Fmt.(list ~sep:nop) pp_condition_name' ppf + let pp_renamed_item_layout: renamed_item_layout Pretty.printer = fun ppf -> function | Renamed_elementary { usage } -> Pretty.record [ @@ -158,3 +175,12 @@ let pp_item ppf = function Fmt.field "record" (fun () -> record_name) Fmt.string; Pretty.vfield "def" (fun () -> def) pp_record_renaming'; ] ppf () + | Data_condition { def; record = { record_name; _ }; item } -> + Pretty.record_with_conditional_fields [ + T Fmt.(styled `Yellow @@ any "data condition"); + T (Fmt.field "record" (fun () -> record_name) Fmt.string); + I'(~&item.item_qualname <> None, + Fmt.field "item" (fun () -> ~&item.item_qualname) pp_qualname'_opt, + Fmt.field "item-offset" (fun () -> ~&item.item_offset) pp_offset); + T (Pretty.vfield "def" (fun () -> def) pp_condition_name'); + ] ppf () diff --git a/src/lsp/cobol_data/data_types.ml b/src/lsp/cobol_data/data_types.ml index fd0516f51..5eb3fdaea 100644 --- a/src/lsp/cobol_data/data_types.ml +++ b/src/lsp/cobol_data/data_types.ml @@ -61,16 +61,19 @@ and item_definition = item_qualname: Cobol_ptree.qualname with_loc option; item_redefines: Cobol_ptree.qualname with_loc option; (* redef only *) item_layout: item_layout; - item_offset: Data_memory.offset; (** offset w.r.t record address *) + item_offset: Data_memory.offset; (** offset w.r.t record address, not taking + subscripts/dimensions/refmords into + account. *) item_size: Data_memory.size; item_length: length; + item_conditions: condition_names; item_redefinitions: item_redefinitions; } and item_layout = | Elementary_item of { usage: usage; - value: Cobol_ptree.literal with_loc option; + init_value: Cobol_ptree.literal with_loc option; } | Struct_item of { @@ -88,7 +91,7 @@ and item_layout = { items: item_definitions; length: int with_loc; (* int for now *) - value: Cobol_ptree.literal with_loc option; + init_values: Cobol_ptree.literal with_loc list; (* list for now *) (* TODO: keys, indexing; *) } (* -> ([>`table], [>`fixed_length]) item_layout *) @@ -99,7 +102,7 @@ and item_layout = min_occurs: int with_loc; (* int for now *) max_occurs: int with_loc; (* ditto *) depending: Cobol_ptree.qualname with_loc; - value: Cobol_ptree.literal with_loc option; + init_values: Cobol_ptree.literal with_loc list; (* list for now *) (* TODO: keys, indexing; *) } (* -> ([>`table], [>`variable_length]) item_layout *) @@ -109,12 +112,19 @@ and item_layout = capacity: Cobol_ptree.qualname with_loc option; min_capacity: int with_loc option; max_capacity: int with_loc option; - value: Cobol_ptree.literal with_loc option; + init_values: Cobol_ptree.literal with_loc list; (* list for now *) initialized: bool with_loc; (* TODO: keys, indexing *) } (* NOTE: considered fixed-length in ISO/IEC *) (* -> ([>`table], [>`fixed_length]) item_layout *) +and condition_names = condition_name with_loc list +and condition_name = + { + condition_name_qualname: Cobol_ptree.qualname with_loc; + condition_name_item: Cobol_ptree.condition_name_item; (* for now *) + } + (** Note: RENAMES could be represented by simply adding an (optional, non-constant) offset to redefinitions (and use group layouts with FILLERs throughout to forbid using the new name as a qualifier). @@ -180,6 +190,12 @@ type item = record: record; def: record_renaming with_loc; } + | Data_condition of + { + record: record; + item: item_definition with_loc; + def: condition_name with_loc; + } (* | Const_record: data_const_record -> definition *) (* screen: "_ OCCURS n TIMES" only. Max 2 dimensions. *) diff --git a/src/lsp/cobol_data/data_visitor.ml b/src/lsp/cobol_data/data_visitor.ml index aa1293074..d89cc7529 100644 --- a/src/lsp/cobol_data/data_visitor.ml +++ b/src/lsp/cobol_data/data_visitor.ml @@ -30,6 +30,9 @@ class ['a] folder = object method fold_item_definition': (item_definition with_loc, 'a) fold = default method fold_item_definition: (item_definition, 'a) fold = default method fold_item_redefinitions: (item_redefinitions, 'a) fold = default + method fold_condition_names: (condition_names, 'a) fold = default + method fold_condition_name': (condition_name with_loc, 'a) fold = default + method fold_condition_name: (condition_name, 'a) fold = default method fold_renamed_item_layout: (renamed_item_layout, 'a) fold = default method fold_record_renamings: (record_renamings, 'a) fold = default method fold_record_renaming': (record_renaming with_loc, 'a) fold = default @@ -63,12 +66,13 @@ and fold_item_definition (v: _ #folder) = handle v#fold_item_definition ~continue:begin fun { item_qualname; item_layout; item_offset; item_size; item_redefinitions; item_redefines; - item_length = _; } x -> x + item_conditions; item_length = _ } x -> x >> Cobol_ptree.Terms_visitor.fold_qualname'_opt v item_qualname >> Cobol_ptree.Terms_visitor.fold_qualname'_opt v item_redefines >> fold_item_layout v item_layout >> fold_memory_offset v item_offset >> fold_memory_size v item_size + >> fold_condition_names v item_conditions >> fold_item_redefinitions v item_redefinitions end @@ -79,31 +83,52 @@ and fold_item_redefinitions (v: _ #folder) = and fold_item_layout (v: _ #folder) = handle v#fold_item_layout ~continue:begin fun l x -> match l with - | Elementary_item { usage; value } -> x + | Elementary_item { usage; init_value } -> x >> fold_usage v usage - >> Cobol_ptree.Terms_visitor.fold_literal'_opt v value + >> Cobol_ptree.Terms_visitor.fold_literal'_opt v init_value | Struct_item { fields } -> x >> fold_item_definitions v fields - | Fixed_table { items; length; value } -> x + | Fixed_table { items; length; init_values } -> x >> fold_item_definitions v items >> fold_int' v length - >> Cobol_ptree.Terms_visitor.fold_literal'_opt v value - | Depending_table { items; min_occurs; max_occurs; depending; value } -> x + >> fold_list v init_values + ~fold:Cobol_ptree.Terms_visitor.fold_literal' + | Depending_table { items; min_occurs; max_occurs; depending; + init_values } -> x >> fold_item_definitions v items >> fold_int' v min_occurs >> fold_int' v max_occurs >> Cobol_ptree.Terms_visitor.fold_qualname' v depending - >> Cobol_ptree.Terms_visitor.fold_literal'_opt v value + >> fold_list v init_values + ~fold:Cobol_ptree.Terms_visitor.fold_literal' | Dynamic_table { items; capacity; min_capacity; max_capacity; - value; initialized } -> x + init_values; initialized } -> x >> fold_item_definitions v items >> Cobol_ptree.Terms_visitor.fold_qualname'_opt v capacity >> fold_option v ~fold:fold_int' min_capacity >> fold_option v ~fold:fold_int' max_capacity - >> Cobol_ptree.Terms_visitor.fold_literal'_opt v value + >> fold_list v init_values + ~fold:Cobol_ptree.Terms_visitor.fold_literal' >> fold' v ~fold:fold_bool initialized end +and fold_condition_names (v: _ #folder) = + handle v#fold_condition_names + ~continue:(fold_list v ~fold:fold_condition_name') + +and fold_condition_name' (v: _ #folder) = + handle' v#fold_condition_name' v ~fold:fold_condition_name + +and fold_condition_name (v: _ #folder) = + handle v#fold_condition_name + ~continue:begin fun { condition_name_qualname; + condition_name_item = _ } x -> x + >> Cobol_ptree.Terms_visitor.fold_qualname' v condition_name_qualname + (* NB: we skip the item def for now as its representation is temporary *) + (* >> Cobol_ptree.Data_sections_visitor.fold_condition_name_item v *) + (* condition_name_item *) + end + let fold_renamed_item_layout (v: _ #folder) = handle v#fold_renamed_item_layout ~continue:begin function diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index c9a46f63c..c1d484369 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -78,12 +78,15 @@ let find_data_definition Lsp_position.{ location_of; location_of_srcloc } match Cobol_unit.Qualmap.find qn cu.unit_data.data_items.named with | Data_item { def = { loc; _ }; _ } | Data_renaming { def = { loc; _ }; _ } + | Data_condition { def = { loc; _ }; _ } when not focus_on_name_in_defintions -> [location_of_srcloc loc] | Data_item { def; _ } -> Option.(to_list @@ map location_of ~&def.item_qualname) | Data_renaming { def; _ } -> [location_of ~&def.renaming_name] + | Data_condition { def; _ } -> + [location_of ~&def.condition_name_qualname] | exception Not_found | exception Cobol_unit.Qualmap.Ambiguous _ when not allow_notifications -> diff --git a/src/lsp/cobol_typeck/typeck_data_diagnostics.ml b/src/lsp/cobol_typeck/typeck_data_diagnostics.ml index 4d9b16015..90e402fef 100644 --- a/src/lsp/cobol_typeck/typeck_data_diagnostics.ml +++ b/src/lsp/cobol_typeck/typeck_data_diagnostics.ml @@ -17,6 +17,17 @@ open Cobol_common.Srcloc.INFIX module DIAGS = Cobol_common.Diagnostics module NEL = Cobol_data.Types.NEL +type entry = + | Redefines_entry + | Renames_entry + | Condition_name_entry + +let pp_entry ppf e = + Pretty.string ppf @@ match e with + | Redefines_entry -> "REDEFINES" + | Renames_entry -> "RENAMES" + | Condition_name_entry -> "condition-name entry" + type error = | Item_not_allowed_in_section of { @@ -32,11 +43,6 @@ type error = level: int with_loc; expected: int list; } - | Misplaced_redefinition of - { - loc: srcloc; - expl: misplacement_explanation; - } | Unexpected_redefinition_level of { redef_loc: srcloc; @@ -66,11 +72,6 @@ type error = redef_redefines: Cobol_ptree.name with_loc; table_item: (* ([>`table], _) *)Cobol_data.Types.item_definition with_loc; } - | Misplaced_renaming of - { - loc: srcloc; - expl: misplacement_explanation; - } | Missing_picture_clause_for_elementary_item of { item_name: Cobol_ptree.data_name with_loc option; @@ -112,6 +113,12 @@ type error = { qualname: Cobol_ptree.qualname with_loc; } + | Misplaced of + { + entry: entry; + loc: srcloc; + expl: misplacement_explanation; + } | Pending_feature of { name: string; @@ -141,8 +148,7 @@ let error_loc = function | Invalid_renaming_of_variable_length_range { loc; _ } | Item_not_allowed_in_section { level = { loc; _ }; _ } | Item_not_found { qualname = { loc; _ } } - | Misplaced_redefinition { loc; _ } - | Misplaced_renaming { loc; _ } + | Misplaced { loc; _ } | Missing_picture_clause_for_elementary_item { item_loc = loc; _ } | Occurs_in_rename_operand { operand = { loc; _ }; _ } | Pending_feature { loc; _ } @@ -181,9 +187,6 @@ let pp_error ppf = function | Unexpected_level_number { level; expected } -> Pretty.print ppf "Unexpected level number %02d: expected %a" ~&level (pp_one_of Fmt.(fmt "%02d")) expected - | Misplaced_redefinition { expl; _ } -> - Pretty.print ppf "Misplaced REDEFINES %a" - pp_misplacement_explanation expl | Unexpected_redefinition_level { expected_level; redef_level; redef_name; _ } -> Pretty.print ppf "Invalid level %02d for %a with REDEFINES clause; \ @@ -201,9 +204,6 @@ let pp_error ppf = function | Redefinition_of_table_item { table_item; _ } -> Pretty.print ppf "Invalid redefinition of item with OCCURS clause%a" Fmt.(option (sp ++ Cobol_ptree.pp_qualname')) ~&table_item.item_qualname - | Misplaced_renaming { expl; _ } -> - Pretty.print ppf "Misplaced@ RENAMES@ %a\ - " pp_misplacement_explanation expl | Missing_picture_clause_for_elementary_item { item_name; _ } -> Pretty.print ppf "Missing PICTURE clause for %a" pp_data_name'_opt item_name @@ -225,6 +225,9 @@ let pp_error ppf = function Cobol_data.Picture.pp_error ppf ~&error | Item_not_found { qualname; _ } -> Pretty.print ppf "Item '%a' not found" Cobol_ptree.pp_qualname' qualname + | Misplaced { entry; expl; _ } -> + Pretty.print ppf "Misplaced@ %a@ %a\ + " pp_entry entry pp_misplacement_explanation expl | Pending_feature { name; _ } -> Pretty.print ppf "%s is not supported yet" name diff --git a/src/lsp/cobol_typeck/typeck_data_items.ml b/src/lsp/cobol_typeck/typeck_data_items.ml index bf34fc922..b1317f476 100644 --- a/src/lsp/cobol_typeck/typeck_data_items.ml +++ b/src/lsp/cobol_typeck/typeck_data_items.ml @@ -36,6 +36,7 @@ type acc = current_qualification: Cobol_ptree.qualname option; item_stack: item_stack; current_qualmap: Cobol_data.Types.item_definition with_loc Qualmap.t; + pending_conditions: condition_name_under_construction list; filler_count: int; definitions: Cobol_unit.Types.data_definitions; references: srcloc list Cobol_unit.Qual.MAP.t; @@ -56,8 +57,12 @@ and item_under_construction = (* item currently being assembled *) item_redefines: Cobol_ptree.qualname with_loc option; (* REDEFINES iff <> None *) item_rev_fields: Cobol_data.Types.item_definition with_loc list; item_rev_renames: Cobol_data.Types.record_renaming with_loc list; + item_rev_conditions: Cobol_data.Types.condition_names; (* TODO: subscripting info? + others? *) } +and condition_name_under_construction = + Cobol_data.Types.condition_name with_loc * + Cobol_data.Types.item_definition with_loc (* --- *) @@ -73,6 +78,7 @@ let init (config: unit_config) = current_qualification = None; current_qualmap = Qualmap.empty; item_stack = []; + pending_conditions = []; filler_count = 0; definitions = { @@ -146,8 +152,17 @@ let define_record acc ~renamings (record_item: item_definition with_loc) = (Data_renaming { record; def }) data_items end data_items renamings in + let data_items = (* add condition names *) + List.fold_left begin fun data_items (def, item) -> + (* TODO: [validation] entries have no name. (The current parse-tree does + not allow those). *) + add_named_def ~&def.condition_name_qualname + (Data_condition { record; def; item }) data_items + end data_items acc.pending_conditions + in { acc with current_qualmap = Qualmap.empty; + pending_conditions = []; definitions = { data_items; data_records = record :: acc.definitions.data_records } } @@ -266,15 +281,21 @@ let register_def acc (def: item_definition with_loc) = let item_definition acc - ({ item_name; item_loc; item_qualname; item_qualifier; + ({ item_name; + item_loc; + item_qualname; + item_qualifier; item_redefines; - item_offset; item_size; + item_offset; + item_size; item_clauses = { occurs; picture; values; clause_diags; _ }; - item_rev_fields; _ } as item) + item_rev_fields; + item_rev_conditions; _ } as item) : (acc * Cobol_data.Types.item_definition with_loc, acc) result = let open Cobol_data.Types in let acc = { acc with diags = Typeck_diagnostics.union acc.diags clause_diags } in + let item_conditions = List.rev item_rev_conditions in let item_definitions_length item_definitions = NEL.fold_left Fixed_length item_definitions ~f:begin fun l item_def -> if ~&item_def.item_length = Variable_length @@ -296,11 +317,13 @@ let item_definition acc item_qualname = None; (* implicit FILLER *) item_redefines; item_layout = Fixed_table { items = NEL.One item'; - length; value = None }; + length; + init_values = [] }; item_offset = item.item_offset; item_size = Cobol_data.Memory.mult_int item.item_size ~&length; item_length = Fixed_length; item_redefinitions = []; + item_conditions = []; } &@ loc | OccursDepending { min_occurs; max_occurs; depending; loc = _ } -> let dep_size = Cobol_data.Memory.valof ~&depending in @@ -311,11 +334,12 @@ let item_definition acc min_occurs = int min_occurs; max_occurs = int max_occurs; depending; - value = None }; + init_values = [] }; item_offset = item.item_offset; item_size = Cobol_data.Memory.repeat item.item_size ~by:dep_size; item_length = Variable_length; item_redefinitions = []; + item_conditions = []; } &@ loc | OccursDynamic { capacity; min_capacity; max_capacity; initialized; loc = _ } -> @@ -327,11 +351,12 @@ let item_definition acc min_capacity = opt int min_capacity; max_capacity = opt int max_capacity; initialized; - value = None }; + init_values = [] }; item_offset = item.item_offset; item_size = Cobol_data.Memory.size_of_dynamic_table; item_length = Fixed_length; item_redefinitions = []; + item_conditions = []; } &@ loc in let group items = @@ -343,13 +368,14 @@ let item_definition acc | FixedOccurs { length; loc = _ } -> Fixed_table { items; length = int length; - value = None }, + init_values = [] }, item_definitions_length items | OccursDepending { min_occurs; max_occurs; depending; loc = _ } -> Depending_table { items; min_occurs = int min_occurs; max_occurs = int max_occurs; - depending; value = None }, + depending; + init_values = [] }, Variable_length | OccursDynamic { capacity; min_capacity; max_capacity; initialized; loc = _ } -> @@ -357,7 +383,8 @@ let item_definition acc capacity = opt qualify capacity; min_capacity = opt int min_capacity; max_capacity = opt int max_capacity; - initialized; value = None }, + initialized; + init_values = [] }, Fixed_length in { @@ -367,21 +394,23 @@ let item_definition acc item_offset = ~&(NEL.hd items).item_offset; item_size; item_length; - item_redefinitions = [] + item_redefinitions = []; + item_conditions; } &@ item_loc in if item_rev_fields = [] then (* elementary (or table of elementary) *) match elementary_usage_n_value acc item with - | Ok (acc, (Usage picture as usage), value) -> + | Ok (acc, (Usage picture as usage), init_value) -> let data_size = Cobol_data.Picture.data_size picture.category in Ok (elementary acc ({ item_qualname; item_redefines = None; - item_layout = Elementary_item { usage; value }; + item_layout = Elementary_item { usage; init_value }; item_offset; item_size = Cobol_data.Memory.const_size data_size; item_length = Fixed_length; - item_redefinitions = [] } &@ item_loc)) + item_redefinitions = []; + item_conditions } &@ item_loc)) | Error acc -> Error acc (* just skip *) else (* group item *) @@ -397,11 +426,22 @@ let item_definition acc Ok (register_def acc def, def) +let commit_conditions acc def { item_rev_conditions; _ } = + let pending_conditions = + List.fold_left begin fun pcs cond_name -> + (cond_name, def) :: pcs + end acc.pending_conditions item_rev_conditions + in + { acc with pending_conditions } + + let item_definitions acc items = List.fold_left begin fun (acc, rev_defs, renamings) item -> match item_definition acc item with | Ok (acc, def) -> - acc, def :: rev_defs, List.rev_append item.item_rev_renames renamings + commit_conditions acc def item, + def :: rev_defs, + List.rev_append item.item_rev_renames renamings | Error acc -> acc, rev_defs, renamings end (acc, [], []) items @@ -535,8 +575,8 @@ let on_redefinition_item acc item_clauses ~level ~name ~redefined_name ~loc = let acc = flush_item_stack ~down_to_level:(~&level + 1) acc in match def_n_redef_items acc.item_stack with | [], _ -> (* no redefinable item *) - error acc @@ - Misplaced_redefinition { loc; expl = Following "no definition" } + error acc @@ Misplaced { entry = Redefines_entry; loc; + expl = Following "no definition" } | { item_level = expected_level; item_loc = expected_redefined_loc; _ } as redefined_item :: _, base_stack -> let acc = @@ -594,7 +634,8 @@ let on_redefinition_item acc item_clauses ~level ~name ~redefined_name ~loc = item_redefines; item_clauses; item_rev_fields = []; - item_rev_renames = [] } :: acc.item_stack } + item_rev_renames = []; + item_rev_conditions = [] } :: acc.item_stack } let on_item ~at_level { payload = Cobol_ptree.{ data_level; data_name; @@ -629,7 +670,8 @@ let on_item ~at_level { payload = Cobol_ptree.{ data_level; data_name; item_redefines = None; item_clauses; item_rev_fields = []; - item_rev_renames = [] } :: acc.item_stack } + item_rev_renames = []; + item_rev_conditions = [] } :: acc.item_stack } let dummy_renamed_elementary = @@ -712,13 +754,15 @@ let on_rename ({ loc; _ } as rename_item) acc = let acc = flush_item_stack ~down_to_level:02 acc in match acc.item_stack with | [] -> - error acc @@ Misplaced_renaming { loc; expl = Following "no definition" } + error acc @@ Misplaced { entry = Renames_entry; loc; + expl = Following "no definition" } | { item_level; item_qualifier; _ } as top_item :: item_stack -> let acc = match item_level with | 01 -> (* For later: or FD or SD *) acc | l -> (* report misplacement, but keep going anyways *) - error acc @@ Misplaced_renaming { loc; expl = Following_level l } + error acc @@ Misplaced { entry = Renames_entry; loc; + expl = Following_level l } in match renaming acc ?renaming_qualifier:item_qualifier rename_item with | Ok (acc, renaming) -> @@ -728,11 +772,26 @@ let on_rename ({ loc; _ } as rename_item) acc = | Error acc -> acc -(* let on_condition ({ loc; _ } as condition_item) acc = *) -(* match acc.item_stack with *) -(* | [] -> *) -(* error acc @@ Misplaced_condition { loc; expl = Following "no definition" } *) -(* | top_item *) +let on_condition_name (cond_name: Cobol_ptree.condition_name_item with_loc) acc = + match acc.item_stack with + | [] -> + error acc @@ Misplaced { entry = Condition_name_entry; + loc = ~@cond_name; + expl = Following "no definition" } + | top_item :: item_stack -> + let condition_name_qualname + = qualify ~&cond_name.condition_name acc.item_stack in + let condition_name + = { condition_name_qualname; + condition_name_item = ~&cond_name } &@<- cond_name in + let top_item = + { top_item with + item_rev_conditions = condition_name :: top_item.item_rev_conditions } + in + { acc with item_stack = top_item :: item_stack } + + +(* --- *) let enter_section section acc = @@ -754,6 +813,11 @@ let data_definitions = object method! fold_linkage_section _ acc = Visitor.do_children @@ enter_section Linkage acc + (* TODO *) + method! fold_communication_section _ = Visitor.skip + method! fold_report_section _ = Visitor.skip + method! fold_screen_section _ = Visitor.skip + method! fold_data_item' ({ payload = { data_level; _ }; loc } as item) acc = Visitor.skip_children @@ match ~&data_level, acc.current_storage with @@ -776,16 +840,17 @@ let data_definitions = object error acc (Invalid_level_number { level = rename_level }) |> on_rename item (* rename anyways *) - (* TODO: fold_constant_item' *) + (* TODO: fold_constant_item'; + see https://github.com/OCamlPro/superbol-studio-oss/issues/53 *) - (* method! fold_condition_name_item' ({ payload = { condition_level; *) - (* _ }; _ } as item) acc = *) - (* Visitor.skip_children @@ match ~&condition_level with (\* check in case *\) *) - (* | 88 -> *) - (* on_condition item acc *) - (* | _ -> *) - (* error acc (Invalid_level_number { level = condition_level }) |> *) - (* on_condition item (\* emit anyways *\) *) + method! fold_condition_name_item' ({ payload = { condition_name_level; + _ }; _ } as item) acc = + Visitor.skip_children @@ match ~&condition_name_level with (* check in case *) + | 88 -> + on_condition_name item acc + | _ -> + error acc (Invalid_level_number { level = condition_name_level }) |> + on_condition_name item (* emit anyways *) (* TODO: fold_screen_item' *) (* TODO: fold_report_group_item' *) diff --git a/src/lsp/cobol_typeck/typeck_outputs.ml b/src/lsp/cobol_typeck/typeck_outputs.ml index 688158d9d..ce3afa04d 100644 --- a/src/lsp/cobol_typeck/typeck_outputs.ml +++ b/src/lsp/cobol_typeck/typeck_outputs.ml @@ -76,7 +76,12 @@ let register_data_item_ref ~loc item refs = | Some qn -> register_data_qualref ~&qn ~loc refs let register_data_renaming_ref ~loc renaming refs = - register_data_qualref ~&(~&renaming.Cobol_data.Types.renaming_name) ~loc refs + register_data_qualref + ~&(~&renaming.Cobol_data.Types.renaming_name) ~loc refs + +let register_condition_name_ref ~loc cond_name refs = + register_data_qualref + ~&(~&cond_name.Cobol_data.Types.condition_name_qualname) ~loc refs let register_procedure_ref ~loc block refs = match Cobol_unit.Types.block_name block with diff --git a/src/lsp/cobol_typeck/typeck_procedure.ml b/src/lsp/cobol_typeck/typeck_procedure.ml index 9a6e3f225..43f544540 100644 --- a/src/lsp/cobol_typeck/typeck_procedure.ml +++ b/src/lsp/cobol_typeck/typeck_procedure.ml @@ -169,7 +169,7 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure let visitor = object inherit [acc] Cobol_unit.Visitor.folder - method! fold_qualname qn acc = (* TODO: qualname' *) + method! fold_qualname qn acc = (* TODO: data_name' instead *) let loc = baseloc_of_qualname qn in Visitor.skip_children @@ match Cobol_unit.Qualmap.find qn data_definitions.data_items.named with @@ -179,6 +179,9 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure | Data_renaming { def; _ } -> { acc with refs = Typeck_outputs.register_data_renaming_ref ~loc def acc.refs } + | Data_condition { def; _ } -> + { acc with + refs = Typeck_outputs.register_condition_name_ref ~loc def acc.refs } | exception Not_found -> acc (* ignored for now, as we don't process all the DATA DIV. yet. *) | exception Cobol_unit.Qualmap.Ambiguous matching_qns -> diff --git a/src/lsp/cobol_unit/unit_visitor.ml b/src/lsp/cobol_unit/unit_visitor.ml index 9a89a7738..dbcc2885a 100644 --- a/src/lsp/cobol_unit/unit_visitor.ml +++ b/src/lsp/cobol_unit/unit_visitor.ml @@ -40,10 +40,10 @@ end let fold_unit_config (v: _ #folder) = leaf v#fold_unit_config let fold_data_definitions (v: _ #folder) = - handle v#fold_data_definitions (* skip items view *) + handle v#fold_data_definitions ~continue:begin fun { data_records; data_items = _ } x -> x - >> fold_list v data_records - ~fold:Cobol_data.Visitor.fold_record + (* traverse via full records, skip individual items view *) + >> fold_list ~fold:Cobol_data.Visitor.fold_record v data_records end let fold_procedure_paragraph (v: _ #folder) = diff --git a/test/cobol_typeck/dune b/test/cobol_typeck/dune index 5ffd17b10..e277ed5da 100644 --- a/test/cobol_typeck/dune +++ b/test/cobol_typeck/dune @@ -6,7 +6,7 @@ ok_pic ko_pic ok_renames ko_renames ok_redefines ko_redefines - ok_conditions + ok_conditions ko_conditions ko_proc_names prog_printer) (preprocess diff --git a/test/cobol_typeck/ko_conditions.ml b/test/cobol_typeck/ko_conditions.ml new file mode 100644 index 000000000..5572bbb22 --- /dev/null +++ b/test/cobol_typeck/ko_conditions.ml @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* Copyright (c) 2022-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the GNU Affero General Public *) +(* License version 3 found in the LICENSE.md file in the root directory *) +(* of this source tree. *) +(* *) +(**************************************************************************) + +open Prog_printer + +let dotest = Typeck_testing.show_diagnostics + +let%expect_test "misplaced-condition" = + dotest @@ prog "misplaced-condition" + ~working_storage:{| + 88 X-IS-A VALUE "A". + 77 X PIC X. + |}; + [%expect {| + prog.cob:4.7-4.27: + 1 PROGRAM-ID. misplaced-condition. + 2 DATA DIVISION. + 3 WORKING-STORAGE SECTION. + 4 > 88 X-IS-A VALUE "A". + ---- ^^^^^^^^^^^^^^^^^^^^ + 5 77 X PIC X. + 6 PROCEDURE DIVISION. + >> Error: Misplaced condition-name entry following no definition |}];; diff --git a/test/cobol_typeck/ok_conditions.ml b/test/cobol_typeck/ok_conditions.ml index f0aa1af21..9d4d90d58 100644 --- a/test/cobol_typeck/ok_conditions.ml +++ b/test/cobol_typeck/ok_conditions.ml @@ -15,6 +15,94 @@ open Prog_printer let dotest = Typeck_testing.show_data +let%expect_test "simple-conditions" = + dotest @@ prog "simple-conditions" + ~working_storage:{| + 77 X PIC X. + 88 X-IS-A VALUE "A". + |}; + [%expect {| + prog.cob:4.7-4.18: + 1 PROGRAM-ID. simple-conditions. + 2 DATA DIVISION. + 3 WORKING-STORAGE SECTION. + 4 > 77 X PIC X. + ---- ^^^^^^^^^^^ + 5 88 X-IS-A VALUE "A". + 6 PROCEDURE DIVISION. + Item definition: { + qualname: X + offset: 0 + size: 1 + layout: { + elementary + usage: { + display (dev: temporary) + category: ALPHANUMERIC(1) + } + } + conditions: { + qualname: X-IS-A IN X + values: ... + } + } |}];; + + +let%expect_test "qualified-conditions" = + dotest @@ prog "simple-conditions" + ~working_storage:{| + 01 W. + 02 X PIC X VALUE "X". + 88 X-IS-A VALUE "A". + 88 X-IS-B VALUE "B". + |} + ~procedure:{| + DISPLAY X + SET X-IS-A IN X IN W TO TRUE + DISPLAY X + SET X-IS-B TO TRUE + DISPLAY X. + |}; + [%expect {| + prog.cob:4.7-5.30: + 1 PROGRAM-ID. simple-conditions. + 2 DATA DIVISION. + 3 WORKING-STORAGE SECTION. + 4 > 01 W. + ---- ^^^^^ + 5 > 02 X PIC X VALUE "X". + ---- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + 6 88 X-IS-A VALUE "A". + 7 88 X-IS-B VALUE "B". + Item definition: { + qualname: W + offset: 0 + size: 1 + layout: { + structure + fields: { + qualname: X IN W + offset: 0 + size: 1 + layout: { + elementary + usage: { + display (dev: temporary) + category: ALPHANUMERIC(1) + } + } + conditions: { + qualname: X-IS-A IN X IN W + values: ... + }{ + qualname: X-IS-B IN X IN W + values: ... + } + } + } + } |}];; + + let%expect_test "group-conditions" = dotest @@ prog "group-conditions" ~working_storage:{| @@ -65,6 +153,10 @@ let%expect_test "group-conditions" = } } } + conditions: { + qualname: X-1 IN X + values: ... + } } prog.cob:7.7-10.37: 4 01 X. @@ -108,4 +200,8 @@ let%expect_test "group-conditions" = } } } + conditions: { + qualname: Y-1 IN W + values: ... + } } |}];;