Basic handling of condition-names

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 ()

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. *)

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

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 ->

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