Merge pull request #257 from nberth/more-preproc-directives

Support more compiler directives

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}

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}

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}

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

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

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 }