[M extension] variable category generalization (#217)

src/mlang/backend_compilers/dgfip_gen_files.ml

@@ -130,27 +130,37 @@ let is_input st = match st with Base | Computed -> false | _ -> true
 let is_computed st = match st with Base | Computed -> true | _ -> false
 
 let input_var_subtype iv : var_subtype =
-  match Pos.unmark iv.Mast.input_subtyp with
-  | Mast.Context -> Context
-  | Family -> Family
-  | Penality -> Penality
-  | Income -> Income
+  List.find_map
+    (fun t ->
+      match Pos.unmark t with
+      | "contexte" -> Some Context
+      | "famille" -> Some Family
+      | "penalite" -> Some Penality
+      | "revenu" -> Some Income
+      | _ -> None)
+    iv.Mast.input_category
+  |> function
+  | Some s -> s
+  | None -> assert false
 (* Missing CorrIncome and Variation (actually not used *)
 
 let computed_var_subtype cv : var_subtype =
   let is_base =
     List.exists
-      (fun ct ->
-        match Pos.unmark ct with Mast.Base -> true | GivenBack -> false)
-      cv.Mast.comp_subtyp
+      (fun ct -> String.equal (Pos.unmark ct) Mast.base_category)
+      cv.Mast.comp_category
   in
   if is_base then Base else Computed
 
 let computed_var_is_output cv =
   List.exists
-    (fun st ->
-      match Pos.unmark st with Mast.GivenBack -> true | Base -> false)
-    cv.Mast.comp_subtyp
+    (fun st -> String.equal (Pos.unmark st) Mast.givenback_category)
+    cv.Mast.comp_category
+
+let input_var_is_output iv =
+  List.exists
+    (fun st -> String.equal (Pos.unmark st) Mast.givenback_category)
+    iv.Mast.input_category
 
 let consider_output is_ebcdic attribs =
   is_ebcdic = false
@@ -164,12 +174,12 @@ let consider_output is_ebcdic attribs =
 (* Used to generated the array names *)
 let subtype_name subtyp =
   match subtyp with
-  | Context -> "contexte"
-  | Family -> "famille"
-  | Income -> "revenu"
+  | Context -> Mast.context_category
+  | Family -> Mast.family_category
+  | Income -> Mast.income_category
   | CorrIncome -> "revenu_correc"
   | Variation -> "variation"
-  | Penality -> "penalite"
+  | Penality -> Mast.penality_category
   | Base -> assert false (* never used *)
   | Computed -> assert false
 (* never used *)
@@ -178,10 +188,10 @@ let subtype_name subtyp =
 let req_type_name req_type =
   match req_type with
   | Computed (Some typ) -> subtype_name typ
-  | Computed None -> "calculee"
+  | Computed None -> Mast.computed_category
   | Input (Some typ) -> subtype_name typ
-  | Input None -> "saisie"
-  | Output -> "restituee"
+  | Input None -> Mast.input_category
+  | Output -> Mast.givenback_category
   | Debug i when i <= 0 -> "debug"
   | Debug i -> Printf.sprintf "debug%02d" i
 
@@ -299,7 +309,7 @@ let get_vars prog is_ebcdic =
                 let tvar = input_var_subtype iv in
                 let idx1, idx2, idxo_opt =
                   next_idx idx tvar
-                    (iv.input_given_back
+                    (input_var_is_output iv
                     && consider_output is_ebcdic iv.Mast.input_attributes)
                     1
                 in
@@ -510,7 +520,7 @@ let gen_var fmt req_type opt ~idx ~name ~tvar ~is_output ~typ_opt ~attributes
   if opt.with_libelle then Format.fprintf fmt ", \"%s\"" desc
   else Format.fprintf fmt " /*\"%s\"*/" desc;
   begin
-    match (req_type, tvar) with
+    match ((req_type : gen_type), tvar) with
     | Input _, Income -> Format.fprintf fmt ", \"%s\"" name
     | _ -> ()
   end;
@@ -615,7 +625,7 @@ let gen_desc fmt vars ~alias_only is_ebcdic =
           | Base | Computed -> begin
               (* computed var: only output *)
               match idxo_opt with
-              | Some idx -> Some ("restituee", idx)
+              | Some idx -> Some (Mast.givenback_category, idx)
               | None -> None
             end
           | _ -> Some (subtype_name tvar, idx2)

src/mlang/m_frontend/format_mast.ml

@@ -235,19 +235,6 @@ let format_rule fmt (r : rule) =
        (pp_unmark format_formula))
     r.rule_formulaes
 
-let format_computed_typ fmt (t : computed_typ) =
-  match t with
-  | Base -> Format.fprintf fmt "base"
-  | GivenBack -> Format.fprintf fmt "restituee"
-
-let format_input_variable_subtype fmt (t : input_variable_subtype) =
-  Format.pp_print_string fmt
-    (match t with
-    | Context -> "contexte"
-    | Family -> "famille"
-    | Penality -> "penalite"
-    | Income -> "revenu")
-
 let format_value_typ fmt (t : value_typ) =
   Format.pp_print_string fmt
     (match t with
@@ -258,28 +245,27 @@ let format_value_typ fmt (t : value_typ) =
     | Integer -> "ENTIER"
     | Real -> "REEL")
 
-let format_input_attribute fmt
-    ((n, v) : input_variable_attribute Pos.marked * literal Pos.marked) =
+let format_input_attribute fmt ((n, v) : variable_attribute) =
   Format.fprintf fmt "%s = %a" (Pos.unmark n) format_literal (Pos.unmark v)
 
 let format_input_variable fmt (v : input_variable) =
-  Format.fprintf fmt "%a saisie %a %a%s %a : %s%a;" format_variable_name
-    (Pos.unmark v.input_name) format_input_variable_subtype
-    (Pos.unmark v.input_subtyp)
+  Format.fprintf fmt "%a %s %a %a %a : %s%a;" format_variable_name
+    (Pos.unmark v.input_name) input_category
+    (pp_print_list_space Format.pp_print_string)
+    (List.map Pos.unmark v.input_category)
     (pp_print_list_space format_input_attribute)
-    v.input_attributes
-    (if v.input_given_back then " restituee" else "")
-    format_variable_name (Pos.unmark v.input_alias)
+    v.input_attributes format_variable_name (Pos.unmark v.input_alias)
     (Pos.unmark v.input_description)
     (option_print format_value_typ)
     (option_bind Pos.unmark v.input_typ)
 
 let format_computed_variable fmt (v : computed_variable) =
-  Format.fprintf fmt "%s%a calculee %a : %a%s;" (Pos.unmark v.comp_name)
+  Format.fprintf fmt "%s%a %s %a : %a%s;" (Pos.unmark v.comp_name)
     (option_print Format.pp_print_int)
     (option_bind Pos.unmark v.comp_table)
-    (pp_print_list_space (pp_unmark format_computed_typ))
-    v.comp_subtyp
+    computed_category
+    (pp_print_list_space (pp_unmark Format.pp_print_string))
+    v.comp_category
     (option_print format_value_typ)
     (option_bind Pos.unmark v.comp_typ)
     (Pos.unmark v.comp_description)
@@ -323,6 +309,17 @@ let format_error_ fmt (e : error_) =
        (pp_unmark Format.pp_print_string))
     e.error_descr
 
+let format_var_type (t : var_type) =
+  match t with Input -> input_category | Computed -> computed_category
+
+let format_var_category fmt (c : var_category_decl) =
+  Format.fprintf fmt "%s %a :@ attributs %a"
+    (format_var_type c.var_type)
+    (pp_print_list_space (pp_unmark Format.pp_print_string))
+    c.var_category
+    (pp_print_list_comma (pp_unmark Format.pp_print_string))
+    c.var_attributes
+
 let format_source_file_item fmt (i : source_file_item) =
   match i with
   | Application app ->
@@ -338,6 +335,9 @@ let format_source_file_item fmt (i : source_file_item) =
   | Error e -> format_error_ fmt e
   | Output o ->
       Format.fprintf fmt "sortie(%a);" format_variable_name (Pos.unmark o)
+  | VarCatDecl c ->
+      Format.fprintf fmt "variable category %a;" format_var_category
+        (Pos.unmark c)
 
 let format_source_file fmt (f : source_file) =
   pp_print_list_endline (pp_unmark format_source_file_item) fmt f

src/mlang/m_frontend/format_mast.mli

@@ -22,6 +22,8 @@ val format_unop : Format.formatter -> Mast.unop -> unit
 
 val format_value_typ : Format.formatter -> Mast.value_typ -> unit
 
+val format_var_type : Mast.var_type -> string
+
 val format_variable : Format.formatter -> Mast.variable -> unit
 
 val format_source_file : Format.formatter -> Mast.source_file -> unit

src/mlang/m_frontend/mast.ml

@@ -340,12 +340,7 @@ type rule = {
 
 (**{3 Input variables}*)
 
-(** Unused for now, except for typechecking: [Income] should be a real number
-    corresponding to an amount of money *)
-type input_variable_subtype = Context | Family | Penality | Income
-
-type input_variable_attribute = string
-(** Attributes are unused for now *)
+type variable_attribute = string Pos.marked * literal Pos.marked
 
 (** Here are all the types a value can have. Date types don't seem to be used at
     all though. *)
@@ -359,27 +354,19 @@ type value_typ =
 
 type input_variable = {
   input_name : variable_name Pos.marked;
-  input_subtyp : input_variable_subtype Pos.marked;
-  input_attributes :
-    (input_variable_attribute Pos.marked * literal Pos.marked) list;
-  input_given_back : bool;
-      (** An input variable given back ("restituee") means that it's also an
-          output *)
+  input_category : string Pos.marked list;
+  input_attributes : variable_attribute list;
   input_alias : variable_name Pos.marked;  (** Unused for now *)
   input_description : string Pos.marked;
   input_typ : value_typ Pos.marked option;
 }
 
-(** A [GivenBack] variable is an output of the program *)
-type computed_typ = Base | GivenBack
-
 type computed_variable = {
   comp_name : variable_name Pos.marked;
   comp_table : int Pos.marked option;
       (** size of the table, [None] for non-table variables *)
-  comp_attributes :
-    (input_variable_attribute Pos.marked * literal Pos.marked) list;
-  comp_subtyp : computed_typ Pos.marked list;
+  comp_attributes : variable_attribute list;
+  comp_category : string Pos.marked list;
   comp_typ : value_typ Pos.marked option;
   comp_description : string Pos.marked;
 }
@@ -390,6 +377,31 @@ type variable_decl =
       (** The literal is the constant value *)
   | InputVar of input_variable Pos.marked
 
+type var_type = Input | Computed
+
+type var_category_decl = {
+  var_type : var_type;
+  var_category : string Pos.marked list;
+  var_attributes : string Pos.marked list;
+}
+
+(* standard categories *)
+let input_category = "saisie"
+
+let computed_category = "calculee"
+
+let base_category = "base"
+
+let givenback_category = "restituee"
+
+let family_category = "famille"
+
+let income_category = "revenu"
+
+let context_category = "contexte"
+
+let penality_category = "penalite"
+
 (**{2 Verification clauses}*)
 
 (** These clauses are expression refering to the variables of the program. They
@@ -437,7 +449,7 @@ type source_file_item =
   | Error of error_  (** Declares an error *)
   | Output of variable_name Pos.marked  (** Declares an output variable *)
   | Function  (** Declares a function, unused *)
-
+  | VarCatDecl of var_category_decl Pos.marked
 (* TODO: parse something here *)
 
 type source_file = source_file_item Pos.marked list