diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml
index 304935b4a..742a0653e 100644
--- a/src/mlang/backend_compilers/dgfip_gen_files.ml
+++ b/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)
diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml
index 778ee7629..3f41c0e62 100644
--- a/src/mlang/m_frontend/format_mast.ml
+++ b/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
diff --git a/src/mlang/m_frontend/format_mast.mli b/src/mlang/m_frontend/format_mast.mli
index 4abf28dea..08b18b313 100644
--- a/src/mlang/m_frontend/format_mast.mli
+++ b/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
diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml
index c8c5cafc3..bcad026a7 100644
--- a/src/mlang/m_frontend/mast.ml
+++ b/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
diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml
index 7e3ae5b19..b1c6f9d19 100644
--- a/src/mlang/m_frontend/mast_to_mir.ml
+++ b/src/mlang/m_frontend/mast_to_mir.ml
@@ -454,10 +454,175 @@ let get_constants (p : Mast.program) : float Pos.marked ConstMap.t =
let belongs_to_iliad_app (r : Mast.application Pos.marked list) : bool =
List.exists (fun app -> Pos.unmark app = "iliad") r
+let sort_attributes (attrs : Mast.variable_attribute list) =
+ List.sort
+ (fun c1 c2 -> String.compare (Pos.unmark (fst c1)) (Pos.unmark (fst c2)))
+ attrs
+
+let get_var_categories (p : Mast.program) =
+ let categories =
+ List.fold_left
+ (fun decls source_file ->
+ List.fold_left
+ (fun decls source_file_item ->
+ match Pos.unmark source_file_item with
+ | Mast.VarCatDecl (catdecl, pos) ->
+ let normalized_decl =
+ {
+ catdecl with
+ var_category =
+ List.sort
+ (fun c1 c2 ->
+ String.compare (Pos.unmark c1) (Pos.unmark c2))
+ catdecl.var_category;
+ var_attributes =
+ List.sort
+ (fun c1 c2 ->
+ String.compare (Pos.unmark c1) (Pos.unmark c2))
+ catdecl.var_attributes;
+ }
+ in
+ let already_defined =
+ let decl_l = List.length normalized_decl.var_category in
+ List.find_opt
+ (fun (decl, _pos) ->
+ decl_l = List.length decl.Mast.var_category
+ && List.for_all2
+ (fun a b ->
+ String.equal (Pos.unmark a) (Pos.unmark b))
+ normalized_decl.var_category decl.Mast.var_category)
+ decls
+ in
+ begin
+ match already_defined with
+ | None -> ()
+ | Some (_decl, pos) ->
+ Cli.warning_print
+ "Category \"%s\" defined more than once:@;\
+ Already defined %a"
+ (String.concat " "
+ (Format_mast.format_var_type normalized_decl.var_type
+ :: List.map Pos.unmark normalized_decl.var_category))
+ Pos.format_position pos
+ end;
+ (normalized_decl, pos) :: decls
+ | _ -> decls)
+ decls source_file)
+ [] p
+ in
+ let categories =
+ (* Sorted to match longest category first *)
+ List.sort
+ (fun c1 c2 ->
+ compare
+ (List.length (Pos.unmark c2).Mast.var_category)
+ (List.length (Pos.unmark c1).Mast.var_category))
+ categories
+ in
+ if categories = [] then
+ Cli.warning_print
+ "No variable categories defined. No check will be performed.";
+ categories
+
+let check_var_category (categories : Mast.var_category_decl Pos.marked list)
+ (var : Mast.variable_decl) =
+ let rec category_included_in cbase ctest =
+ (* assume sorted lists *)
+ match (cbase, ctest) with
+ | [], _ -> true
+ | _, [] -> false
+ | chb :: ctb, cht :: ctt ->
+ if String.equal chb cht then category_included_in ctb ctt
+ else
+ (* Allows variables to have more tags than the declared category.
+ Since the declaration are sorted by tag number, we will match the
+ most precise one first. We can however have have two declared
+ categories that fits but are not included in one another. *)
+ category_included_in cbase ctt
+ in
+ let attributes_triaging abase atest =
+ let rec aux (missing, surplus) abase atest =
+ match (abase, atest) with
+ | [], _ ->
+ (missing, List.map (fun a -> Pos.unmark (fst a)) atest @ surplus)
+ | _, [] -> (List.map (fun a -> Pos.unmark a) abase @ missing, surplus)
+ | ahb :: atb, aht :: att ->
+ let ahb = Pos.unmark ahb in
+ let aht = Pos.unmark (fst aht) in
+ let comp = String.compare ahb aht in
+ if comp = 0 then aux (missing, surplus) atb att
+ else if comp < 0 then aux (ahb :: missing, surplus) atb atest
+ else aux (missing, aht :: surplus) abase att
+ in
+ aux ([], []) abase atest
+ in
+ let var_name, var_typ, var_cat, var_attrs =
+ match var with
+ | Mast.ConstVar _ -> assert false
+ | Mast.ComputedVar v ->
+ let v = Pos.unmark v in
+ ( Pos.unmark v.comp_name,
+ Mast.Computed,
+ v.comp_category,
+ v.comp_attributes )
+ | Mast.InputVar v ->
+ let v = Pos.unmark v in
+ ( Pos.unmark v.input_name,
+ Mast.Input,
+ v.input_category,
+ v.input_attributes )
+ in
+ let var_cat = List.map Pos.unmark var_cat in
+ if categories = [] then ()
+ else
+ let categories =
+ List.filter
+ (fun cat -> (Pos.unmark cat).Mast.var_type = var_typ)
+ categories
+ in
+ let var_cat = List.sort String.compare var_cat in
+ let var_attrs = sort_attributes var_attrs in
+ match
+ List.find_all
+ (fun cat ->
+ category_included_in
+ (List.map Pos.unmark (Pos.unmark cat).Mast.var_category)
+ var_cat)
+ categories
+ with
+ | [] ->
+ Cli.warning_print "Variable %s does not fit in any declared categories."
+ var_name
+ | [ cat ] ->
+ let missing, surplus =
+ attributes_triaging (Pos.unmark cat).var_attributes var_attrs
+ in
+ if missing <> [] then
+ Cli.warning_print
+ "Variable %s (category %s) is missing the following attributes: %s"
+ var_name
+ (String.concat " " var_cat)
+ (String.concat " " missing);
+ if surplus <> [] then
+ Cli.warning_print
+ "Variable %s (category %s) has some unexpected attributes: %s"
+ var_name
+ (String.concat " " var_cat)
+ (String.concat " " surplus)
+ | multiple_cats ->
+ Cli.warning_print "Variable %s fits more than one category:@\n%a"
+ var_name
+ (Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun fmt cat ->
+ Format.fprintf fmt "- %s"
+ (String.concat " "
+ (List.map Pos.unmark (Pos.unmark cat).Mast.var_category))))
+ multiple_cats
+
(** Retrieves variable declaration data. Done in a separate pass because we
don't want to deal with sorting the dependencies between files or inside
files. *)
let get_variables_decl (p : Mast.program)
+ (categories : Mast.var_category_decl Pos.marked list)
(const_map : float Pos.marked ConstMap.t) :
var_decl_data Mir.VariableMap.t * Mir.Error.t list * Mir.idmap =
let vars, idmap, errors, out_list =
@@ -467,11 +632,11 @@ let get_variables_decl (p : Mast.program)
(fun (vars, (idmap : Mir.idmap), errors, out_list) source_file_item ->
match Pos.unmark source_file_item with
| Mast.VariableDecl var_decl -> (
- let subtypes = Mir.subtypes_of_decl var_decl in
match var_decl with
| Mast.ConstVar (_, _) ->
(vars, idmap, errors, out_list) (* already treated before *)
| Mast.ComputedVar _ | Mast.InputVar _ -> (
+ check_var_category categories var_decl;
let var_name =
match var_decl with
| Mast.ComputedVar v -> (Pos.unmark v).Mast.comp_name
@@ -507,30 +672,17 @@ let get_variables_decl (p : Mast.program)
match var_decl with
| Mast.ComputedVar cvar ->
let cvar = Pos.unmark cvar in
- let attrs =
- ( Pos.same_pos_as "calculee" cvar.Mast.comp_name,
- Pos.same_pos_as (Mast.Float 1.)
- cvar.Mast.comp_name )
- :: cvar.comp_attributes
- in
- let attrs =
- if
- List.exists
- (fun x -> Pos.unmark x = Mast.Base)
- cvar.Mast.comp_subtyp
- then
- ( Pos.same_pos_as "base" cvar.Mast.comp_name,
- Pos.same_pos_as (Mast.Float 1.)
- cvar.Mast.comp_name )
- :: attrs
- else attrs
+ let category =
+ Mast.computed_category
+ :: List.map Pos.unmark cvar.comp_category
in
let new_var =
Mir.Variable.new_var cvar.Mast.comp_name None
cvar.Mast.comp_description
(dummy_exec_number
(Pos.get_position cvar.Mast.comp_name))
- ~attributes:attrs ~subtypes ~origin:None
+ ~attributes:cvar.comp_attributes ~category
+ ~origin:None
~is_table:(Pos.unmark_option cvar.Mast.comp_table)
in
let new_var_data =
@@ -557,16 +709,19 @@ let get_variables_decl (p : Mast.program)
if
List.exists
(fun x ->
- match Pos.unmark x with
- | Mast.GivenBack -> true
- | Mast.Base -> false)
- cvar.Mast.comp_subtyp
+ String.equal (Pos.unmark x)
+ Mast.givenback_category)
+ cvar.Mast.comp_category
then cvar.Mast.comp_name :: out_list
else out_list
in
(new_vars, new_idmap, errors, new_out_list)
| Mast.InputVar ivar ->
let ivar = Pos.unmark ivar in
+ let category =
+ Mast.input_category
+ :: List.map Pos.unmark ivar.input_category
+ in
let new_var =
Mir.Variable.new_var ivar.Mast.input_name
(Some (Pos.unmark ivar.Mast.input_alias))
@@ -574,7 +729,7 @@ let get_variables_decl (p : Mast.program)
(dummy_exec_number
(Pos.get_position ivar.Mast.input_name))
~attributes:ivar.input_attributes ~origin:None
- ~subtypes ~is_table:None
+ ~category ~is_table:None
(* Input variables also have a low order *)
in
let new_var_data =
@@ -585,12 +740,15 @@ let get_variables_decl (p : Mast.program)
Pos.unmark_option ivar.Mast.input_typ
with
| Some x -> Some x
- | None -> (
- match
- Pos.unmark ivar.Mast.input_subtyp
- with
- | Mast.Income -> Some Mast.Real
- | _ -> None)
+ | None ->
+ if
+ List.exists
+ (fun t ->
+ String.equal Mast.income_category
+ (Pos.unmark t))
+ ivar.input_category
+ then Some Mast.Real
+ else None
end;
var_decl_is_table = None;
var_decl_descr =
@@ -736,7 +894,7 @@ let duplicate_var (var : Mir.Variable.t) (exec_number : Mir.execution_number)
local variables *)
in
Mir.Variable.new_var var.name None var.descr exec_number
- ~attributes:var.attributes ~origin ~subtypes:var.subtypes
+ ~attributes:var.attributes ~origin ~category:var.category
~is_table:var.is_table
(** Linear pass that fills [idmap] with all the variable assignments along with
@@ -1351,7 +1509,7 @@ let get_conds (error_decls : Mir.Error.t list)
}
(Pos.unmark verif_cond).Mast.verif_cond_expr
in
- let subtypes =
+ let category =
(* Verifications are maped to a dummy variable, we use it
to store all the subtypes of variables appearing in its
expression to avoid going through it later when we sort
@@ -1362,7 +1520,7 @@ let get_conds (error_decls : Mir.Error.t list)
(fun subtypes st ->
if List.mem st subtypes then subtypes
else st :: subtypes)
- subtypes var.Mir.subtypes)
+ subtypes var.Mir.category)
[] (Pos.unmark e)
in
let err =
@@ -1407,7 +1565,7 @@ let get_conds (error_decls : Mir.Error.t list)
Mir.seq_number = 0;
Mir.pos = Pos.get_position verif_cond;
}
- ~attributes:[] ~origin:None ~subtypes ~is_table:None
+ ~attributes:[] ~origin:None ~category ~is_table:None
in
( Mir.VariableMap.add dummy_var
{
@@ -1429,7 +1587,10 @@ let get_conds (error_decls : Mir.Error.t list)
let translate (p : Mast.program) : Mir.program =
let const_map = get_constants p in
- let var_decl_data, error_decls, idmap = get_variables_decl p const_map in
+ let var_category_decls = get_var_categories p in
+ let var_decl_data, error_decls, idmap =
+ get_variables_decl p var_category_decls const_map
+ in
let idmap = get_var_redefinitions p idmap const_map in
let rule_data, var_data =
get_rules_and_var_data idmap var_decl_data const_map p
diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll
index 7221c029a..b956a3f5c 100644
--- a/src/mlang/m_frontend/mlexer.mll
+++ b/src/mlang/m_frontend/mlexer.mll
@@ -62,10 +62,6 @@ rule token = parse
{ INTEGER }
| "REEL"
{ REAL }
-| "base"
- { BASE }
-| "restituee"
- { GIVEN_BACK }
| "tableau"
{ TABLE }
| '['
@@ -78,16 +74,12 @@ rule token = parse
{ CONST }
| "alias"
{ ALIAS }
-| "contexte"
- { CONTEXT }
-| "famille"
- { FAMILY }
-| "penalite"
- { PENALITY }
-| "revenu"
- { INCOME }
| "saisie"
{ INPUT }
+| "variable"
+ { VARIABLE }
+| "attribut"
+ { ATTRIBUT }
| '('
{ LPAREN }
| ')'
diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly
index 60c72c091..238871188 100644
--- a/src/mlang/m_frontend/mparser.mly
+++ b/src/mlang/m_frontend/mparser.mly
@@ -22,8 +22,8 @@ along with this program. If not, see .
open Parse_utils
type comp_subtyp_or_attr =
- | CompSubTyp of computed_typ Pos.marked
- | Attr of input_variable_attribute Pos.marked * literal Pos.marked
+ | CompSubTyp of string Pos.marked
+ | Attr of variable_attribute
let parse_to_literal (v: parse_val) : literal = match v with
| ParseVar v -> Variable v
@@ -45,10 +45,10 @@ along with this program. If not, see .
%token RANGE
%token BOOLEAN DATE_YEAR DATE_DAY_MONTH_YEAR DATE_MONTH INTEGER REAL
-%token ONE IN APPLICATION CHAINING TYPE BASE GIVEN_BACK TABLE
-%token COMPUTED CONST ALIAS CONTEXT FAMILY PENALITY INCOME INPUT FOR
+%token ONE IN APPLICATION CHAINING TYPE TABLE
+%token COMPUTED CONST ALIAS INPUT FOR
%token RULE IF THEN ELSE ENDIF ERROR VERIFICATION ANOMALY DISCORDANCE CONDITION
-%token INFORMATIVE OUTPUT FONCTION
+%token INFORMATIVE OUTPUT FONCTION VARIABLE ATTRIBUT
%token EOF
@@ -72,7 +72,6 @@ source_file:
| i = source_file_item is = source_file { i::is }
| EOF { [] }
-
source_file_item:
| a = application { (Application a, mk_position $sloc) }
| c = chaining { let (s, aps) = c in (Chaining (s, aps), mk_position $sloc) }
@@ -82,6 +81,26 @@ source_file_item:
| e = error_ { (Error e, mk_position $sloc) }
| o = output { (Output o, mk_position $sloc) }
| fonction { (Function, mk_position $sloc) }
+| c = var_category_decl { (VarCatDecl c, mk_position $sloc) }
+
+var_category_decl:
+| VARIABLE var_type = var_typ c = symbol_with_pos* COLON ATTRIBUT
+ attr = separated_nonempty_list(COMMA, symbol_with_pos) SEMICOLON
+ {
+ ({
+ var_type;
+ var_category = c;
+ var_attributes = attr;
+ },
+ mk_position $sloc)
+ }
+
+var_typ:
+| INPUT { Input }
+| COMPUTED { Computed }
+
+%inline symbol_with_pos:
+| s = SYMBOL { (s, mk_position $sloc) }
fonction:
| SYMBOL COLON FONCTION SYMBOL SEMICOLON { () }
@@ -126,8 +145,8 @@ computed_variable_descr:
| descr = STRING { (parse_string descr, mk_position $sloc) }
computed_attr_or_subtyp:
-| attr = input_variable_attribute { let (x, y) = attr in Attr (x,y) }
-| subtyp = computed_variable_subtype { CompSubTyp subtyp }
+| attr = variable_attribute { let (x, y) = attr in Attr (x,y) }
+| cat = symbol_with_pos { CompSubTyp cat }
computed_variable:
| name = computed_variable_name size = computed_variable_table? COMPUTED
@@ -138,7 +157,7 @@ computed_variable:
comp_table = size;
comp_attributes = List.map (fun x -> match x with Attr (x, y) -> (x, y) | _ -> assert false (* should not happen *))
(List.filter (fun x -> match x with Attr _ -> true | _ -> false) subtyp);
- comp_subtyp = List.map (fun x -> match x with CompSubTyp x -> x | _ -> assert false (* should not happen *))
+ comp_category = List.map (fun x -> match x with CompSubTyp x -> x | _ -> assert false (* should not happen *))
(List.filter (fun x -> match x with CompSubTyp _ -> true | _ -> false) subtyp);
comp_description = descr;
comp_typ = typ;
@@ -147,41 +166,28 @@ computed_variable:
computed_variable_table:
| TABLE LBRACKET size = SYMBOL RBRACKET { (int_of_string size, mk_position $sloc) }
-computed_variable_subtype:
-| BASE { (Base, mk_position $sloc) }
-| GIVEN_BACK { (GivenBack, mk_position $sloc) }
-
input_variable_name:
| name = SYMBOL COLON { (parse_variable_name $sloc name, mk_position $sloc) }
input_descr:
descr = STRING { (parse_string descr, mk_position $sloc) }
-input_attr_or_subtyp_or_given_back:
-| attr = input_variable_attribute { ((None, Some attr), false) }
-| subtyp = input_variable_subtype { ((Some subtyp, None), false) }
-| GIVEN_BACK { ((None, None), true) }
-
+input_attr_or_category:
+| attr = variable_attribute { (None, Some attr) }
+| cat = symbol_with_pos { (Some cat, None) }
input_variable:
| name = input_variable_name INPUT
- subtyp = input_attr_or_subtyp_or_given_back* alias = input_variable_alias COLON descr = input_descr
+ category_attrs = input_attr_or_category* alias = input_variable_alias COLON descr = input_descr
typ = value_type?
SEMICOLON {
- let (subtyp_attrs, given_back) = List.split subtyp in
- let (subtyp, attrs) = List.split subtyp_attrs in
+ let (category, attrs) = List.split category_attrs in
InputVar ({
input_name = name;
- input_subtyp = begin
- let subtyp =
- List.map (fun x -> match x with None -> assert false (* should not happen *) | Some x -> x)
- (List.filter (fun x -> x <> None) subtyp)
- in
- if List.length subtyp > 1 then
- Errors.raise_spanned_error "multiple subtypes for an input variable" (mk_position $sloc)
- else
- List.hd subtyp
- end;
+ input_category =
+ List.map
+ (fun x -> match x with None -> assert false (* should not happen *) | Some x -> x)
+ (List.filter (fun x -> x <> None) category);
input_attributes = begin
let attrs =
List.map (fun x -> match x with None -> assert false (* should not happen *) | Some x -> x)
@@ -189,7 +195,6 @@ input_variable:
in
attrs
end;
- input_given_back = List.exists (fun x -> x) given_back;
input_alias = alias;
input_typ = typ;
input_description = descr;
@@ -198,23 +203,17 @@ input_variable:
input_variable_alias:
| ALIAS alias = SYMBOL { (parse_variable_name $sloc alias, mk_position $sloc) }
-input_variable_attribute_name:
+variable_attribute_name:
| attr = SYMBOL { (attr, mk_position $sloc) }
-input_variable_attribute_value:
+variable_attribute_value:
lit = SYMBOL { (parse_literal $sloc lit, mk_position $sloc) }
-input_variable_attribute:
-| attr = input_variable_attribute_name EQUALS
- lit = input_variable_attribute_value
+variable_attribute:
+| attr = variable_attribute_name EQUALS
+ lit = variable_attribute_value
{ (attr, lit) }
-input_variable_subtype:
-| CONTEXT { (Context, mk_position $sloc) }
-| FAMILY { (Family, mk_position $sloc) }
-| PENALITY { (Penality, mk_position $sloc) }
-| INCOME { (Income, mk_position $sloc) }
-
value_type:
| TYPE typ = value_type_prim { typ }
diff --git a/src/mlang/m_ir/format_mir.ml b/src/mlang/m_ir/format_mir.ml
index fdf2ceaa9..c0068bf74 100644
--- a/src/mlang/m_ir/format_mir.ml
+++ b/src/mlang/m_ir/format_mir.ml
@@ -30,18 +30,6 @@ let format_execution_number_short fmt (exec_number : execution_number) =
let format_typ fmt (t : typ) =
Format.pp_print_string fmt (match t with Real -> "real")
-let format_subtype fmt (st : variable_subtype) =
- Format.pp_print_string fmt
- (match st with
- | Context -> "contexte"
- | Family -> "famille"
- | Income -> "revenu"
- | Penality -> "penalite"
- | Base -> "base"
- | GivenBack -> "restituee"
- | Computed -> "calculee"
- | Input -> "saisie")
-
let format_io fmt (io : io) =
Format.pp_print_string fmt
(match io with
diff --git a/src/mlang/m_ir/format_mir.mli b/src/mlang/m_ir/format_mir.mli
index d6fe06864..a9a9f2133 100644
--- a/src/mlang/m_ir/format_mir.mli
+++ b/src/mlang/m_ir/format_mir.mli
@@ -21,8 +21,6 @@ val format_execution_number_short :
val format_typ : Format.formatter -> Mir.typ -> unit
-val format_subtype : Format.formatter -> Mir.variable_subtype -> unit
-
val format_func : Format.formatter -> Mir.func -> unit
val format_literal : Format.formatter -> Mir.literal -> unit
diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml
index f7c8d34d4..6ac712b12 100644
--- a/src/mlang/m_ir/mir.ml
+++ b/src/mlang/m_ir/mir.ml
@@ -61,43 +61,6 @@ let same_execution_number (en1 : execution_number) (en2 : execution_number) :
type variable_id = int
(** Each variable has an unique ID *)
-type variable_subtype =
- | Context
- | Family
- | Penality
- | Income
- | Base
- | GivenBack
- | Computed
- | Input
-
-let subtypes_of_decl (var_decl : Mast.variable_decl) : variable_subtype list =
- match var_decl with
- | ConstVar _ -> []
- | ComputedVar cv ->
- let subtypes =
- List.map
- (fun subtyp ->
- match (Pos.unmark subtyp : Mast.computed_typ) with
- | Base -> Base
- | GivenBack -> GivenBack)
- (Pos.unmark cv).comp_subtyp
- in
- Computed :: subtypes
- | InputVar iv ->
- let iv = Pos.unmark iv in
- let subtypes =
- match (Pos.unmark iv.input_subtyp : Mast.input_variable_subtype) with
- | Context -> [ Context ]
- | Family -> [ Family ]
- | Penality -> [ Penality ]
- | Income -> [ Income ]
- in
- let subtypes =
- if iv.input_given_back then GivenBack :: subtypes else subtypes
- in
- Input :: subtypes
-
type variable = {
name : string Pos.marked; (** The position is the variable declaration *)
execution_number : execution_number;
@@ -107,12 +70,11 @@ type variable = {
id : variable_id;
descr : string Pos.marked;
(** Description taken from the variable declaration *)
- attributes :
- (Mast.input_variable_attribute Pos.marked * Mast.literal Pos.marked) list;
+ attributes : Mast.variable_attribute list;
origin : variable option;
(** If the variable is an SSA duplication, refers to the original
(declared) variable *)
- subtypes : variable_subtype list;
+ category : string list;
is_table : int option;
}
@@ -128,12 +90,11 @@ module Variable = struct
id : variable_id;
descr : string Pos.marked;
(** Description taken from the variable declaration *)
- attributes :
- (Mast.input_variable_attribute Pos.marked * Mast.literal Pos.marked) list;
+ attributes : Mast.variable_attribute list;
origin : variable option;
(** If the variable is an SSA duplication, refers to the original
(declared) variable *)
- subtypes : variable_subtype list;
+ category : string list;
is_table : int option;
}
@@ -146,10 +107,8 @@ module Variable = struct
let new_var (name : string Pos.marked) (alias : string option)
(descr : string Pos.marked) (execution_number : execution_number)
- ~(attributes :
- (Mast.input_variable_attribute Pos.marked * Mast.literal Pos.marked)
- list) ~(origin : t option) ~(subtypes : variable_subtype list)
- ~(is_table : int option) : t =
+ ~(attributes : Mast.variable_attribute list) ~(origin : t option)
+ ~(category : string list) ~(is_table : int option) : t =
{
name;
id = fresh_id ();
@@ -158,7 +117,7 @@ module Variable = struct
execution_number;
attributes;
origin;
- subtypes;
+ category;
is_table;
}
diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli
index 3b06f5f4d..4ecbbf55c 100644
--- a/src/mlang/m_ir/mir.mli
+++ b/src/mlang/m_ir/mir.mli
@@ -24,16 +24,6 @@ type execution_number = {
type variable_id = int
(** Each variable has an unique ID *)
-type variable_subtype =
- | Context
- | Family
- | Penality
- | Income
- | Base
- | GivenBack
- | Computed
- | Input
-
type variable = {
name : string Pos.marked; (** The position is the variable declaration *)
execution_number : execution_number;
@@ -43,12 +33,11 @@ type variable = {
id : variable_id;
descr : string Pos.marked;
(** Description taken from the variable declaration *)
- attributes :
- (Mast.input_variable_attribute Pos.marked * Mast.literal Pos.marked) list;
+ attributes : Mast.variable_attribute list;
origin : variable option;
(** If the variable is an SSA duplication, refers to the original
(declared) variable *)
- subtypes : variable_subtype list;
+ category : string list;
is_table : int option;
}
@@ -234,12 +223,11 @@ module Variable : sig
id : variable_id;
descr : string Pos.marked;
(** Description taken from the variable declaration *)
- attributes :
- (Mast.input_variable_attribute Pos.marked * Mast.literal Pos.marked) list;
+ attributes : Mast.variable_attribute list;
origin : variable option;
(** If the variable is an SSA duplication, refers to the original
(declared) variable *)
- subtypes : variable_subtype list;
+ category : string list;
is_table : int option;
}
@@ -250,9 +238,9 @@ module Variable : sig
string option ->
string Pos.marked ->
execution_number ->
- attributes:(string Pos.marked * Mast.literal Pos.marked) list ->
+ attributes:Mast.variable_attribute list ->
origin:variable option ->
- subtypes:variable_subtype list ->
+ category:string list ->
is_table:int option ->
variable
@@ -334,8 +322,6 @@ val fresh_rule_num : unit -> int
val initial_undef_rule_id : rov_id
-val subtypes_of_decl : Mast.variable_decl -> variable_subtype list
-
val find_var_by_name : program -> string Pos.marked -> variable
(** Get a variable for a given name or alias, because of SSA multiple variables
share a name or alias. If an alias is provided, the variable returned is
diff --git a/src/mlang/mpp_frontend/mpp_frontend.ml b/src/mlang/mpp_frontend/mpp_frontend.ml
index d4b53510b..bdae72328 100644
--- a/src/mlang/mpp_frontend/mpp_frontend.ml
+++ b/src/mlang/mpp_frontend/mpp_frontend.ml
@@ -20,15 +20,16 @@
open Mpp_ir
let filter_of_string (s : string Pos.marked) : var_filter =
- match Pos.unmark s with
+ let us = Pos.unmark s in
+ match us with
| "saisie" -> Saisie None
| "calculee" -> Calculee None
- | "contexte" -> Saisie (Some Context)
- | "famille" -> Saisie (Some Family)
- | "revenu" -> Saisie (Some Income)
- | "penalite" -> Saisie (Some Penality)
- | "base" -> Calculee (Some Base)
- | "restituee" -> Calculee (Some GivenBack)
+ | "contexte" -> Saisie (Some us)
+ | "famille" -> Saisie (Some us)
+ | "revenu" -> Saisie (Some us)
+ | "penalite" -> Saisie (Some us)
+ | "base" -> Calculee (Some us)
+ | "restituee" -> Calculee (Some us)
| unknown ->
Errors.raise_spanned_error
(Format.sprintf "unknown variable category %s" unknown)
diff --git a/src/mlang/mpp_ir/mpp_format.ml b/src/mlang/mpp_ir/mpp_format.ml
index 20418d62c..827038049 100644
--- a/src/mlang/mpp_ir/mpp_format.ml
+++ b/src/mlang/mpp_ir/mpp_format.ml
@@ -25,9 +25,9 @@ let format_scoped_var (fmt : formatter) (sv : scoped_var) : unit =
let format_var_filter (fmt : formatter) (f : var_filter) : unit =
match f with
- | Saisie None -> fprintf fmt "saisie"
- | Calculee None -> fprintf fmt "calculee"
- | Calculee (Some st) | Saisie (Some st) -> Format_mir.format_subtype fmt st
+ | Saisie None -> pp_print_string fmt Mast.input_category
+ | Calculee None -> pp_print_string fmt Mast.computed_category
+ | Calculee (Some st) | Saisie (Some st) -> fprintf fmt "%s" st
let format_callable (fmt : formatter) (f : mpp_callable) =
fprintf fmt "%s"
diff --git a/src/mlang/mpp_ir/mpp_ir.ml b/src/mlang/mpp_ir/mpp_ir.ml
index d0262f4bd..ec5f0ae60 100644
--- a/src/mlang/mpp_ir/mpp_ir.ml
+++ b/src/mlang/mpp_ir/mpp_ir.ml
@@ -30,9 +30,7 @@ type scoped_var =
type mpp_compute_name = string
-type var_filter =
- | Saisie of Mir.variable_subtype option
- | Calculee of Mir.variable_subtype option
+type var_filter = Saisie of string option | Calculee of string option
type mpp_callable =
| Program of Mast.chain_tag (* M codebase *)
diff --git a/src/mlang/mpp_ir/mpp_ir_to_bir.ml b/src/mlang/mpp_ir/mpp_ir_to_bir.ml
index dbe6eb3c0..f66f8b499 100644
--- a/src/mlang/mpp_ir/mpp_ir_to_bir.ml
+++ b/src/mlang/mpp_ir/mpp_ir_to_bir.ml
@@ -89,7 +89,7 @@ let generate_input_condition (crit : Mir.Variable.t -> bool)
(fun var acc -> mk_or (mk_call_present var) acc)
variables_to_check mk_false
-let var_filter_compatible_subtypes (subtypes : Mir.variable_subtype list)
+let var_filter_compatible_subtypes (subtypes : string list)
(filter : Mpp_ir.var_filter) : bool =
match (filter : Mpp_ir.var_filter) with
| Saisie st ->
@@ -97,20 +97,20 @@ let var_filter_compatible_subtypes (subtypes : Mir.variable_subtype list)
| None ->
List.exists
(fun st ->
- match (st : Mir.variable_subtype) with
- | Context | Family | Income | Penality | Input -> true
+ match st with
+ | "contexte" | "famille" | "revenu" | "penalite" | "saisie" ->
+ true
| _ -> false)
subtypes
| Some st -> List.mem st subtypes)
- && List.for_all (( <> ) (Computed : Mir.variable_subtype)) subtypes
+ && List.for_all
+ (fun x -> not (String.equal Mast.computed_category x))
+ subtypes
| Calculee st -> (
match st with
| None ->
List.exists
- (fun st ->
- match (st : Mir.variable_subtype) with
- | Base | Computed -> true
- | _ -> false)
+ (fun st -> match st with "base" | "calculee" -> true | _ -> false)
subtypes
| Some st -> List.mem st subtypes)
@@ -237,10 +237,11 @@ let generate_verif_call (m_program : Mir_interface.full_program)
&&
match filter with
| None -> true
- | Some filter -> var_filter_compatible_subtypes var.Mir.subtypes filter
+ | Some filter -> var_filter_compatible_subtypes var.Mir.category filter
in
if
- test && chain_tag <> Horizontale && List.mem Mir.Penality var.Mir.subtypes
+ test && chain_tag <> Horizontale
+ && List.exists (String.equal Mast.penality_category) var.Mir.category
then
Errors.raise_spanned_error "Penality variable used in verification"
(Pos.get_position cond.Mir.cond_expr)
@@ -334,7 +335,7 @@ and translate_mpp_stmt (mpp_program : Mpp_ir.mpp_compute list)
("mpp_" ^ l, pos)
None ("", pos)
(Mast_to_mir.dummy_exec_number pos)
- ~attributes:[] ~origin:None ~subtypes:[] ~is_table:None
+ ~attributes:[] ~origin:None ~category:[] ~is_table:None
|> Bir.(var_from_mir default_tgv)
in
let ctx =