CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-07 10:35:56 +03:00
Code Issues Projects Releases Wiki Activity

More precise positions for operators throughout

Browse Source
This commit is contained in:
Louis Gesbert 2024-04-30 16:35:08 +02:00
parent 50d686f089
commit cee8e57d02
31 changed files with 362 additions and 338 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/dcalc/from_scopelang.ml
View File

@ -139,7 +139,8 @@ let tag_with_log_entry
let m = mark_tany (Mark.get e) (Expr.pos e) in
if Global.options.trace then
Expr.eappop ~op:(Log (l, markings)) ~tys:[TAny, Expr.pos e] ~args:[e] m
let pos = Expr.pos e in
Expr.eappop ~op:(Log (l, markings), pos) ~tys:[TAny, pos] ~args:[e] m
else e
(* In a list of exceptions, it is normally an error if more than a single one
@ -565,9 +566,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
let v, _ = TopdefName.Map.find (Mark.remove name) ctx.toplevel_vars in
Expr.evar v m
else Expr.eexternal ~name:(Mark.map (fun n -> External_value n) name) m
| EAppOp { op = Add_dat_dur _; args; tys } ->
| EAppOp { op = Add_dat_dur _, opos; args; tys } ->
let args = List.map (translate_expr ctx) args in
Expr.eappop ~op:(Add_dat_dur ctx.date_rounding) ~args ~tys m
Expr.eappop ~op:(Add_dat_dur ctx.date_rounding, opos) ~args ~tys m
| ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _
| ETupleAccess _ | EInj _ | EFatalError _ | EEmpty | EErrorOnEmpty _
| EArray _ | EIfThenElse _ | EAppOp _ ) as e ->

81
compiler/desugared/from_surface.ml
View File

@ -42,7 +42,7 @@ let translate_binop :
Ast.expr boxed =
fun (op, op_pos) pos lhs rhs ->
let op_expr op tys =
Expr.eappop ~op
Expr.eappop ~op:(op, op_pos)
~tys:(List.map (Mark.add op_pos) tys)
~args:[lhs; rhs]
(Untyped { pos })
@ -114,7 +114,10 @@ let translate_binop :
let translate_unop ((op, op_pos) : S.unop Mark.pos) pos arg : Ast.expr boxed =
let op_expr op ty =
Expr.eappop ~op ~tys:[Mark.add op_pos ty] ~args:[arg] (Untyped { pos })
Expr.eappop ~op:(op, op_pos)
~tys:[Mark.add op_pos ty]
~args:[arg]
(Untyped { pos })
in
match op with
| S.Not -> op_expr Not (TLit TBool)
@ -238,12 +241,12 @@ let rec translate_expr
let rec_helper ?(local_vars = local_vars) e =
translate_expr scope inside_definition_of ctxt local_vars e
in
let rec detuplify_list names = function
let rec detuplify_list opos names = function
(* Where a list is expected (e.g. after [among]), as syntactic sugar, if a
tuple is found instead we transpose it into a list of tuples *)
| S.Tuple ls, pos ->
let m = Untyped { pos } in
let ls = List.map (detuplify_list []) ls in
let ls = List.map (detuplify_list opos []) ls in
let rec zip names = function
| [] -> assert false
| [l] -> l
@ -272,7 +275,7 @@ let rec translate_expr
(Expr.make_tuple (Expr.evar x1 m :: explode (Expr.evar x2 m)) m)
tys pos
in
Expr.eappop ~op:Map2 ~args:[f_join; l1; rhs]
Expr.eappop ~op:(Map2, opos) ~args:[f_join; l1; rhs]
~tys:((TAny, pos) :: List.map (fun ty -> TArray ty, pos) tys)
m
in
@ -286,7 +289,7 @@ let rec translate_expr
match Mark.remove expr with
| Paren e -> rec_helper e
| Binop
( (S.And, _pos_op),
( (S.And, pos_op),
( TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)),
_pos_e1 ),
e2 ) ->
@ -302,14 +305,14 @@ let rec translate_expr
let nop_var = Var.make "_" in
Expr.make_abs [| nop_var |]
(Expr.elit (LBool false) emark)
[tau] pos
[tau] pos_op
else
let binding_var = Var.make (Mark.remove binding) in
let local_vars =
Ident.Map.add (Mark.remove binding) binding_var local_vars
in
let e2 = rec_helper ~local_vars e2 in
Expr.make_abs [| binding_var |] e2 [tau] pos)
Expr.make_abs [| binding_var |] e2 [tau] pos_op)
(EnumName.Map.find enum_uid ctxt.enums)
in
Expr.ematch ~e:(rec_helper e1_sub) ~name:enum_uid ~cases emark
@ -493,7 +496,7 @@ let rec translate_expr
in
Expr.edstructaccess ~e ~field:(Mark.remove x) ~name_opt:(get_str ctxt path)
emark
| FunCall ((Builtin b, _), [arg]) ->
| FunCall ((Builtin b, pos), [arg]) ->
let op, ty =
match b with
| S.ToDecimal -> Op.ToRat, TAny
@ -506,7 +509,7 @@ let rec translate_expr
| S.FirstDayOfMonth -> Op.FirstDayOfMonth, TLit TDate
| S.LastDayOfMonth -> Op.LastDayOfMonth, TLit TDate
in
Expr.eappop ~op ~tys:[ty, pos] ~args:[rec_helper arg] emark
Expr.eappop ~op:(op, pos) ~tys:[ty, pos] ~args:[rec_helper arg] emark
| S.Builtin _ ->
Message.error ~pos "Invalid use of built-in: needs one operand"
| FunCall (f, args) ->
@ -723,10 +726,10 @@ let rec translate_expr
| Tuple es -> Expr.etuple (List.map rec_helper es) emark
| TupleAccess (e, n) ->
Expr.etupleaccess ~e:(rec_helper e) ~index:(Mark.remove n - 1) ~size:0 emark
| CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) ->
| CollectionOp ((((S.Filter { f } | S.Map { f }), opos) as op), collection) ->
let param_names, predicate = f in
let collection =
detuplify_list (List.map Mark.remove param_names) collection
detuplify_list opos (List.map Mark.remove param_names) collection
in
let params = List.map (fun n -> Var.make (Mark.remove n)) param_names in
let local_vars =
@ -762,18 +765,19 @@ let rec translate_expr
Expr.eappop
~op:
(match op with
| S.Map _ -> Map
| S.Filter _ -> Filter
| S.Map _, pos -> Map, pos
| S.Filter _, pos -> Filter, pos
| _ -> assert false)
~tys:[TAny, pos; TAny, pos]
~args:[f_pred; collection] emark
| CollectionOp
( S.AggregateArgExtremum { max; default; f = param_names, predicate },
( ( S.AggregateArgExtremum { max; default; f = param_names, predicate },
opos ),
collection ) ->
let default = rec_helper default in
let pos_dft = Expr.pos default in
let collection =
detuplify_list (List.map Mark.remove param_names) collection
detuplify_list opos (List.map Mark.remove param_names) collection
in
let params = List.map (fun n -> Var.make (Mark.remove n)) param_names in
let local_vars =
@ -781,7 +785,7 @@ let rec translate_expr
(fun vars n p -> Ident.Map.add (Mark.remove n) p vars)
local_vars param_names params
in
let cmp_op = if max then Op.Gt else Op.Lt in
let cmp_op = if max then Op.Gt, opos else Op.Lt, opos in
let f_pred =
Expr.make_abs (Array.of_list params)
(rec_helper ~local_vars predicate)
@ -820,10 +824,10 @@ let rec translate_expr
let weighted_result =
Expr.make_let_in weights_var
(TArray (TTuple [TAny, pos; TAny, pos], pos), pos)
(Expr.eappop ~op:Map
(Expr.eappop ~op:(Map, opos)
~tys:[TAny, pos; TArray (TAny, pos), pos]
~args:[add_weight_f; collection] emark)
(Expr.eappop ~op:Reduce
(Expr.eappop ~op:(Reduce, opos)
~tys:[TAny, pos; TAny, pos; TAny, pos]
~args:[reduce_f; default; Expr.evar weights_var emark]
emark)
@ -831,14 +835,15 @@ let rec translate_expr
in
Expr.etupleaccess ~e:weighted_result ~index:0 ~size:2 emark
| CollectionOp
(((Exists { predicate } | Forall { predicate }) as op), collection) ->
((((Exists { predicate } | Forall { predicate }), opos) as op), collection)
->
let collection =
detuplify_list (List.map Mark.remove (fst predicate)) collection
detuplify_list opos (List.map Mark.remove (fst predicate)) collection
in
let init, op =
match op with
| Exists _ -> false, S.Or
| Forall _ -> true, S.And
| Exists _, pos -> false, (S.Or, pos)
| Forall _, pos -> true, (S.And, pos)
| _ -> assert false
in
let init = Expr.elit (LBool init) emark in
@ -857,15 +862,14 @@ let rec translate_expr
Expr.eabs
(Expr.bind
(Array.of_list (acc_var :: params))
(translate_binop (op, pos) pos acc
(rec_helper ~local_vars predicate)))
(translate_binop op pos acc (rec_helper ~local_vars predicate)))
[TAny, pos; TAny, pos]
emark
in
Expr.eappop ~op:Fold
Expr.eappop ~op:(Fold, opos)
~tys:[TAny, pos; TAny, pos; TAny, pos]
~args:[f; init; collection] emark
| CollectionOp (AggregateExtremum { max; default }, collection) ->
| CollectionOp ((AggregateExtremum { max; default }, opos), collection) ->
let collection = rec_helper collection in
let default = rec_helper default in
let op = if max then S.Gt KPoly else S.Lt KPoly in
@ -880,11 +884,11 @@ let rec translate_expr
[TAny, pos; TAny, pos]
pos
in
Expr.eappop ~op:Reduce
Expr.eappop ~op:(Reduce, opos)
~tys:[TAny, pos; TAny, pos; TAny, pos]
~args:[op_f; default; collection]
emark
| CollectionOp (AggregateSum { typ }, collection) ->
| CollectionOp ((AggregateSum { typ }, opos), collection) ->
let collection = rec_helper collection in
let default_lit =
let i0 = Runtime.integer_of_int 0 in
@ -894,7 +898,8 @@ let rec translate_expr
| S.Money -> LMoney (Runtime.money_of_cents_integer i0)
| S.Duration -> LDuration (Runtime.duration_of_numbers 0 0 0)
| t ->
Message.error ~pos "It is impossible to sum values of type %a together"
Message.error ~pos:opos
"It is impossible to sum values of type %a together"
SurfacePrint.format_primitive_typ t
in
let op_f =
@ -905,28 +910,28 @@ let rec translate_expr
let x1 = Expr.make_var v1 emark in
let x2 = Expr.make_var v2 emark in
Expr.make_abs [| v1; v2 |]
(translate_binop (S.Add KPoly, pos) pos x1 x2)
(translate_binop (S.Add KPoly, opos) pos x1 x2)
[TAny, pos; TAny, pos]
pos
in
Expr.eappop ~op:Reduce
Expr.eappop ~op:(Reduce, opos)
~tys:[TAny, pos; TAny, pos; TAny, pos]
~args:[op_f; Expr.elit default_lit emark; collection]
emark
| MemCollection (member, collection) ->
| CollectionOp ((Member { element = member }, opos), collection) ->
let param_var = Var.make "collection_member" in
let param = Expr.make_var param_var emark in
let collection = detuplify_list ["collection_member"] collection in
let collection = detuplify_list opos ["collection_member"] collection in
let init = Expr.elit (LBool false) emark in
let acc_var = Var.make "acc" in
let acc = Expr.make_var acc_var emark in
let f_body =
let member = rec_helper member in
Expr.eappop ~op:Or
Expr.eappop ~op:(Or, opos)
~tys:[TLit TBool, pos; TLit TBool, pos]
~args:
[
Expr.eappop ~op:Eq
Expr.eappop ~op:(Eq, opos)
~tys:[TAny, pos; TAny, pos]
~args:[member; param] emark;
acc;
@ -939,7 +944,7 @@ let rec translate_expr
[TLit TBool, pos; TAny, pos]
emark
in
Expr.eappop ~op:Fold
Expr.eappop ~op:(Fold, opos)
~tys:[TAny, pos; TAny, pos; TAny, pos]
~args:[f; init; collection] emark
@ -1090,7 +1095,7 @@ let merge_conditions
(default_pos : Pos.t) : Ast.expr boxed =
match precond, cond with
| Some precond, Some cond ->
Expr.eappop ~op:And
Expr.eappop ~op:(And, default_pos)
~tys:[TLit TBool, default_pos; TLit TBool, default_pos]
~args:[precond; cond] (Mark.get cond)
| Some precond, None -> Mark.remove precond, Untyped { pos = default_pos }

10
compiler/lcalc/closure_conversion.ml
View File

@ -145,7 +145,8 @@ let rec transform_closures_expr :
(* let env = from_closure_env env in let arg0 = env.0 in ... *)
let new_closure_body =
Expr.make_let_in closure_env_var any_ty
(Expr.eappop ~op:Operator.FromClosureEnv
(Expr.eappop
~op:(Operator.FromClosureEnv, binder_pos)
~tys:[TClosureEnv, binder_pos]
~args:[Expr.evar closure_env_arg_var binder_mark]
binder_mark)
@ -178,7 +179,8 @@ let rec transform_closures_expr :
(Expr.make_tuple
((Bindlib.box_var code_var, binder_mark)
:: [
Expr.eappop ~op:Operator.ToClosureEnv
Expr.eappop
~op:(Operator.ToClosureEnv, binder_pos)
~tys:[TAny, Expr.pos e]
~args:
[
@ -197,7 +199,7 @@ let rec transform_closures_expr :
(Expr.pos e) )
| EAppOp
{
op = (HandleDefaultOpt | Fold | Map | Filter | Reduce) as op;
op = ((HandleDefaultOpt | Fold | Map | Filter | Reduce), _) as op;
tys;
args;
} ->
@ -492,7 +494,7 @@ let rec hoist_closures_expr :
~args:new_args ~tys m )
| EAppOp
{
op = (HandleDefaultOpt | Fold | Map | Filter | Reduce) as op;
op = ((HandleDefaultOpt | Fold | Map | Filter | Reduce), _) as op;
tys;
args;
} ->

3
compiler/lcalc/compile_with_exceptions.ml
View File

@ -51,7 +51,8 @@ let rec translate_default
let exceptions =
List.map (fun except -> Expr.thunk_term (translate_expr except)) exceptions
in
Expr.eappop ~op:Op.HandleDefault
Expr.eappop
~op:(Op.HandleDefault, Expr.pos cons)
~tys:
[
TArray (TArrow ([TLit TUnit, pos], (TAny, pos)), pos), pos;

3
compiler/lcalc/compile_without_exceptions.ml
View File

@ -61,7 +61,8 @@ let rec translate_default
let pos = Expr.mark_pos mark_default in
let exceptions = List.map translate_expr exceptions in
let exceptions_and_cons_ty = Expr.maybe_ty mark_default in
Expr.eappop ~op:Op.HandleDefaultOpt
Expr.eappop
~op:(Op.HandleDefaultOpt, Expr.pos cons)
~tys:
[
TArray exceptions_and_cons_ty, pos;

16
compiler/lcalc/to_ocaml.ml
View File

@ -374,14 +374,14 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
xs_tau format_expr body
| EApp
{
f = EAppOp { op = Log (BeginCall, info); args = [f]; _ }, _;
f = EAppOp { op = Log (BeginCall, info), _; args = [f]; _ }, _;
args = [arg];
_;
}
when Global.options.trace ->
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
format_with_parens f format_with_parens arg
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1]; _ }
| EAppOp { op = Log (VarDef var_def_info, info), _; args = [arg1]; _ }
when Global.options.trace ->
Format.fprintf fmt
"(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)"
@ -393,7 +393,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
var_def_info.log_io_output typ_embedding_name
(var_def_info.log_typ, Pos.no_pos)
format_with_parens arg1
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1]; _ }
| EAppOp { op = Log (PosRecordIfTrueBool, _), _; args = [arg1]; _ }
when Global.options.trace ->
let pos = Expr.pos e in
Format.fprintf fmt
@ -402,15 +402,15 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) format_with_parens arg1
| EAppOp { op = Log (EndCall, info); args = [arg1]; _ }
| EAppOp { op = Log (EndCall, info), _; args = [arg1]; _ }
when Global.options.trace ->
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
format_with_parens arg1
| EAppOp { op = Log _; args = [arg1]; _ } ->
| EAppOp { op = Log _, _; args = [arg1]; _ } ->
Format.fprintf fmt "%a" format_with_parens arg1
| EAppOp
{
op = (HandleDefault | HandleDefaultOpt) as op;
op = ((HandleDefault | HandleDefaultOpt) as op), _;
args = (EArray excs, _) :: _ as args;
_;
} ->
@ -433,14 +433,14 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
Format.fprintf fmt
"@[<hov 2> if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@]"
format_with_parens cond format_with_parens etrue format_with_parens efalse
| EAppOp { op; args; _ } ->
| EAppOp { op = op, pos; args; _ } ->
Format.fprintf fmt "@[<hov 2>%s@ %t%a@]" (Operator.name op)
(fun ppf ->
match op with
| Map2 | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat
| Div_dur_dur | Lt_dur_dur | Lte_dur_dur | Gt_dur_dur | Gte_dur_dur
| Eq_dur_dur ->
Format.fprintf ppf "%a@ " format_pos (Expr.pos e)
Format.fprintf ppf "%a@ " format_pos pos
| _ -> ())
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")

67
compiler/plugins/explain.ml
View File

@ -126,26 +126,44 @@ let neg_op = function
| Op.Gte_dur_dur -> Some Op.Lt_dur_dur
| _ -> None
let rec bool_negation e =
let rec bool_negation pos e =
match Expr.skip_wrappers e with
| ELit (LBool true), m -> ELit (LBool false), m
| ELit (LBool false), m -> ELit (LBool true), m
| EAppOp { op = Op.Not; args = [(e, _)] }, m -> e, m
| (EAppOp { op; tys; args = [e1; e2] }, m) as e -> (
| EAppOp { op = Op.Not, _; args = [(e, _)] }, m -> e, m
| (EAppOp { op = op, opos; tys; args = [e1; e2] }, m) as e -> (
match op with
| Op.And ->
EAppOp { op = Op.Or; tys; args = [bool_negation e1; bool_negation e2] }, m
( EAppOp
{
op = Op.Or, opos;
tys;
args = [bool_negation pos e1; bool_negation pos e2];
},
m )
| Op.Or ->
( EAppOp { op = Op.And; tys; args = [bool_negation e1; bool_negation e2] },
( EAppOp
{
op = Op.And, opos;
tys;
args = [bool_negation pos e1; bool_negation pos e2];
},
m )
| op -> (
match neg_op op with
| Some op -> EAppOp { op; tys; args = [e1; e2] }, m
| Some op -> EAppOp { op = op, opos; tys; args = [e1; e2] }, m
| None ->
( EAppOp { op = Op.Not; tys = [TLit TBool, Expr.mark_pos m]; args = [e] },
( EAppOp
{
op = Op.Not, opos;
tys = [TLit TBool, Expr.mark_pos m];
args = [e];
},
m )))
| (_, m) as e ->
EAppOp { op = Op.Not; tys = [TLit TBool, Expr.mark_pos m]; args = [e] }, m
( EAppOp
{ op = Op.Not, pos; tys = [TLit TBool, Expr.mark_pos m]; args = [e] },
m )
let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
=
@ -169,7 +187,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
let r, env1 = lazy_eval ctx env1 llevel e in
env_elt.reduced <- r, env1;
r, Env.join env env1
| EAppOp { op; args; tys }, m -> (
| EAppOp { op = op, opos; args; tys }, m -> (
if
(not llevel.eval_default)
&& not (List.equal Expr.equal args [ELit LUnit, m])
@ -192,11 +210,13 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
let pos = Expr.mark_pos m in
( EAppOp
{
op = Op.Eq_int_int;
op = Op.Eq_int_int, opos;
tys = [TLit TInt, pos; TLit TInt, pos];
args =
[
EAppOp { op = Op.Length; tys = [aty]; args = [arr] }, m;
( EAppOp
{ op = Op.Length, opos; tys = [aty]; args = [arr] },
m );
ELit (LInt (Runtime.integer_of_int 0)), m;
];
},
@ -245,7 +265,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
(* We did a transformation (removing the outer operator), but further
evaluation may be needed to guarantee that [llevel] is reached *)
lazy_eval ctx env { llevel with eval_match = true } e
| _ -> (EAppOp { op; args; tys }, m), env)
| _ -> (EAppOp { op = op, opos; args; tys }, m), env)
| _ ->
let env, args =
List.fold_left_map
@ -254,7 +274,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
env, e)
env args
in
if not llevel.eval_op then (EAppOp { op; args; tys }, m), env
if not llevel.eval_op then (EAppOp { op = op, opos; args; tys }, m), env
else
let renv = ref env in
(* Dirty workaround returning env and conds from evaluate_operator *)
@ -264,7 +284,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
e
in
let e =
Interpreter.evaluate_operator eval op m Global.En
Interpreter.evaluate_operator eval (op, opos) m Global.En
(* Default language to English but this should not raise any error
messages so we don't care. *)
args
@ -370,14 +390,14 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
~extra_pos:(List.map (fun (e, _) -> "", Expr.pos e) excs)
"Conflicting exceptions")
| EPureDefault e, _ -> lazy_eval ctx env llevel e
| EIfThenElse { cond; etrue; efalse }, _ -> (
| EIfThenElse { cond; etrue; efalse }, m -> (
match eval_to_value env cond with
| (ELit (LBool true), _), _ ->
let condition = cond, env in
let e, env = lazy_eval ctx env llevel etrue in
add_condition ~condition e, env
| (ELit (LBool false), m), _ -> (
let condition = bool_negation cond, env in
let condition = bool_negation (Expr.mark_pos m) cond, env in
let e, env = lazy_eval ctx env llevel efalse in
match efalse with
(* The negated condition is not added for nested [else if] to reduce
@ -541,7 +561,8 @@ let to_graph ctx env expr =
let rec aux env g e =
(* lazy_eval ctx env (result_level base_vars) e *)
match Expr.skip_wrappers e with
| EAppOp { op = ToRat_int | ToRat_mon | ToMoney_rat; args = [arg]; _ }, _ ->
| ( EAppOp { op = (ToRat_int | ToRat_mon | ToMoney_rat), _; args = [arg]; _ },
_ ) ->
aux env g arg
(* we skip conversions *)
| ELit l, _ ->
@ -659,8 +680,9 @@ let program_to_graph
in
let e = Mark.set m (Expr.skip_wrappers e) in
match e with
| EAppOp { op = ToRat_int | ToRat_mon | ToMoney_rat; args = [arg]; tys }, _
->
| ( EAppOp
{ op = (ToRat_int | ToRat_mon | ToMoney_rat), _; args = [arg]; tys },
_ ) ->
aux parent (g, var_vertices, env0) (Mark.set m arg)
(* we skip conversions *)
| ELit l, _ ->
@ -698,7 +720,8 @@ let program_to_graph
let v = G.V.create e in
let g = G.add_vertex g v in
(g, var_vertices, env), v))
| EAppOp { op = Map | Filter | Reduce | Fold; args = _ :: args; _ }, _ ->
| EAppOp { op = (Map | Filter | Reduce | Fold), _; args = _ :: args; _ }, _
->
(* First argument (which is a function) is ignored *)
let v = G.V.create e in
let g = G.add_vertex g v in
@ -707,7 +730,7 @@ let program_to_graph
in
( (List.fold_left (fun g -> G.add_edge g v) g children, var_vertices, env),
v )
| EAppOp { op; args = [lhs; rhs]; _ }, _ ->
| EAppOp { op = op, _; args = [lhs; rhs]; _ }, _ ->
let v = G.V.create e in
let g = G.add_vertex g v in
let (g, var_vertices, env), lhs =
@ -1221,7 +1244,7 @@ let to_dot lang ppf ctx env base_vars g ~base_src_url =
else (* Constants *)
[`Style `Filled; `Fillcolor 0x77aaff; `Shape `Note]
| EStruct _, _ | EArray _, _ -> [`Shape `Record]
| EAppOp { op; _ }, _ -> (
| EAppOp { op = op, _; _ }, _ -> (
match op_kind op with
| `Sum | `Product | _ -> [`Shape `Box] (* | _ -> [] *))
| _ -> [])

2
compiler/scalc/ast.ml
View File

@ -61,7 +61,7 @@ and naked_expr =
| EArray of expr list
| ELit of lit
| EApp of { f : expr; args : expr list }
| EAppOp of { op : operator; args : expr list }
| EAppOp of { op : operator Mark.pos; args : expr list }
| EExternal of { modname : VarName.t Mark.pos; name : string Mark.pos }
type stmt =

4
compiler/scalc/from_lcalc.ml
View File

@ -140,7 +140,7 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr =
e1_stmts, (A.ETupleAccess { e1 = new_e1; index }, Expr.pos expr)
| EAppOp
{
op = Op.HandleDefaultOpt;
op = Op.HandleDefaultOpt, _;
args = [_exceptions; _just; _cons];
tys = _;
}
@ -275,7 +275,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
e_stmts
| EFatalError err -> [SFatalError err, Expr.pos block_expr]
| EAppOp
{ op = Op.HandleDefaultOpt; tys = _; args = [exceptions; just; cons] }
{ op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] }
when ctxt.config.keep_special_ops ->
let exceptions =
match Mark.remove exceptions with

10
compiler/scalc/print.ml
View File

@ -74,15 +74,15 @@ let rec format_expr
Format.fprintf fmt "@[<hov 2>%a@ %a@]" EnumConstructor.format cons
format_expr e
| ELit l -> Print.lit fmt l
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } ->
| EAppOp { op = ((Map | Filter) as op), _; args = [arg1; arg2] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" (Print.operator ~debug) op
format_with_parens arg1 format_with_parens arg2
| EAppOp { op; args = [arg1; arg2] } ->
| EAppOp { op = op, _; args = [arg1; arg2] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
(Print.operator ~debug) op format_with_parens arg2
| EAppOp { op = Log _; args = [arg1] } when not debug ->
| EAppOp { op = Log _, _; args = [arg1] } when not debug ->
Format.fprintf fmt "%a" format_with_parens arg1
| EAppOp { op; args = [arg1] } ->
| EAppOp { op = op, _; args = [arg1] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" (Print.operator ~debug) op
format_with_parens arg1
| EApp { f; args = [] } ->
@ -93,7 +93,7 @@ let rec format_expr
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EAppOp { op; args } ->
| EAppOp { op = op, _; args } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" (Print.operator ~debug) op
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")

27
compiler/scalc/to_c.ml
View File

@ -350,26 +350,23 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
failwith
"should not happen, array initialization is caught at the statement level"
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1 (format_expression ctx) arg2
| EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg2
| EAppOp { op; args = [arg1; arg2] } ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op
(op, Pos.no_pos) (format_expression ctx) arg2
| EAppOp { op = Not; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos)
(format_expression ctx) arg1
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op
(format_expression ctx) arg2
| EAppOp { op = (Not, _) as op; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp
{
op = (Minus_int | Minus_rat | Minus_mon | Minus_dur) as op;
op = ((Minus_int | Minus_rat | Minus_mon | Minus_dur), _) as op;
args = [arg1];
} ->
Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos)
(format_expression ctx) arg1
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1
| EAppOp { op = HandleDefaultOpt | HandleDefault; args = _ } ->
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
| EAppOp { op = (HandleDefaultOpt | HandleDefault), _; args = _ } ->
failwith "should not happen because of keep_special_ops"
| EApp { f; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
@ -378,7 +375,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
(format_expression ctx))
args
| EAppOp { op; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op (op, Pos.no_pos)
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op op
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))

44
compiler/scalc/to_python.ml
View File

@ -298,18 +298,21 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1 (format_expression ctx) arg2
| EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg2
| EAppOp { op; args = [arg1; arg2] } ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op
(op, Pos.no_pos) (format_expression ctx) arg2
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op
(format_expression ctx) arg2
| EApp
{ f = EAppOp { op = Log (BeginCall, info); args = [f] }, _; args = [arg] }
{
f = EAppOp { op = Log (BeginCall, info), _; args = [f] }, _;
args = [arg];
}
when Global.options.trace ->
Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info
(format_expression ctx) f (format_expression ctx) arg
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1] }
| EAppOp { op = Log (VarDef var_def_info, info), _; args = [arg1] }
when Global.options.trace ->
Format.fprintf fmt
"log_variable_definition(%a,@ LogIO(input_io=InputIO.%s,@ \
@ -321,7 +324,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
| Runtime.Reentrant -> "Reentrant")
(if var_def_info.log_io_output then "True" else "False")
(format_expression ctx) arg1
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1] }
| EAppOp { op = Log (PosRecordIfTrueBool, _), _; args = [arg1] }
when Global.options.trace ->
let pos = Mark.get e in
Format.fprintf fmt
@ -330,31 +333,28 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) (format_expression ctx) arg1
| EAppOp { op = Log (EndCall, info); args = [arg1] } when Global.options.trace
->
| EAppOp { op = Log (EndCall, info), _; args = [arg1] }
when Global.options.trace ->
Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info
(format_expression ctx) arg1
| EAppOp { op = Log _; args = [arg1] } ->
| EAppOp { op = Log _, _; args = [arg1] } ->
Format.fprintf fmt "%a" (format_expression ctx) arg1
| EAppOp { op = Not; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos)
(format_expression ctx) arg1
| EAppOp { op = (Not, _) as op; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp
{
op = (Minus_int | Minus_rat | Minus_mon | Minus_dur) as op;
op = ((Minus_int | Minus_rat | Minus_mon | Minus_dur), _) as op;
args = [arg1];
} ->
Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos)
(format_expression ctx) arg1
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1
| EAppOp { op = (HandleDefault | HandleDefaultOpt) as op; args } ->
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
| EAppOp { op = ((HandleDefault | HandleDefaultOpt), _) as op; args } ->
let pos = Mark.get e in
Format.fprintf fmt
"%a(@[<hov 0>SourcePosition(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
format_op (op, pos) (Pos.get_file pos) (Pos.get_start_line pos)
format_op op (Pos.get_file pos) (Pos.get_start_line pos)
(Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos)
format_string_list (Pos.get_law_info pos)
(Format.pp_print_list
@ -381,7 +381,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(format_expression ctx))
args
| EAppOp { op; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op (op, Pos.no_pos)
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op op
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))

29
compiler/scalc/to_r.ml
View File

@ -305,29 +305,26 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
(fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1 (format_expression ctx) arg2
| EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg2
| EAppOp { op; args = [arg1; arg2] } ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op
(op, Pos.no_pos) (format_expression ctx) arg2
| EAppOp { op = Not; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos)
(format_expression ctx) arg1
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op
(format_expression ctx) arg2
| EAppOp { op = (Not, _) as op; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp
{
op = (Minus_int | Minus_rat | Minus_mon | Minus_dur) as op;
op = ((Minus_int | Minus_rat | Minus_mon | Minus_dur), _) as op;
args = [arg1];
} ->
Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos)
(format_expression ctx) arg1
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1
| EAppOp { op = HandleDefaultOpt; _ } ->
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
| EAppOp { op = HandleDefaultOpt, _; _ } ->
Message.error ~internal:true
"R compilation does not currently support the avoiding of exceptions"
| EAppOp { op = HandleDefault as op; args; _ } ->
| EAppOp { op = (HandleDefault as op), _; args; _ } ->
let pos = Mark.get e in
Format.fprintf fmt
"%a(@[<hov 0>catala_position(filename=\"%s\",@ start_line=%d,@ \
@ -359,7 +356,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
(format_expression ctx))
args
| EAppOp { op; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op (op, Pos.no_pos)
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op op
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))

6
compiler/scopelang/from_desugared.ml
View File

@ -39,7 +39,7 @@ let tag_with_log_entry
(markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
if Global.options.trace then
Expr.eappop
~op:(Log (l, markings))
~op:(Log (l, markings), Expr.pos e)
~tys:[TAny, Expr.pos e]
~args:[e] (Mark.get e)
else e
@ -200,9 +200,7 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
~monomorphic:(fun op -> Expr.eappop ~op ~tys ~args m)
~polymorphic:(fun op -> Expr.eappop ~op ~tys ~args m)
~overloaded:(fun op ->
match
Operator.resolve_overload ctx.decl_ctx (Mark.add (Expr.pos e) op) tys
with
match Operator.resolve_overload ctx.decl_ctx op tys with
| op, `Straight -> Expr.eappop ~op ~tys ~args m
| op, `Reversed ->
Expr.eappop ~op ~tys:(List.rev tys) ~args:(List.rev args) m)

2
compiler/shared_ast/definitions.ml
View File

@ -472,7 +472,7 @@ and ('a, 'b, 'm) base_gexpr =
}
-> ('a, < .. >, 'm) base_gexpr
| EAppOp : {
op : 'a operator;
op : 'a operator Mark.pos;
args : ('a, 'm) gexpr list;
tys : typ list;
}

11
compiler/shared_ast/expr.ml
View File

@ -300,7 +300,9 @@ let runtime_to_pos rpos =
let map
(type a b)
?(typ : typ -> typ = Fun.id)
?op:(fop = (fun _ -> invalid_arg "Expr.map" : a Operator.t -> b Operator.t))
?op:(fop =
(fun _ -> invalid_arg "Expr.map"
: a Operator.t Mark.pos -> b Operator.t Mark.pos))
~(f : (a, 'm1) gexpr -> (b, 'm2) boxed_gexpr)
(e : ((a, b, 'm1) base_gexpr, 'm2) marked) : (b, 'm2) boxed_gexpr =
let m = map_ty typ (Mark.get e) in
@ -648,7 +650,7 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
equal e1 e2 && equal_list args1 args2 && Type.equal_list tys1 tys2
| ( EAppOp { op = op1; args = args1; tys = tys1 },
EAppOp { op = op2; args = args2; tys = tys2 } ) ->
Operator.equal op1 op2
Mark.equal Operator.equal op1 op2
&& equal_list args1 args2
&& Type.equal_list tys1 tys2
| EAssert e1, EAssert e2 -> equal e1 e2
@ -719,7 +721,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
List.compare compare args1 args2 @@< fun () ->
List.compare Type.compare tys1 tys2
| EAppOp {op=op1; args=args1; tys=tys1}, EAppOp {op=op2; args=args2; tys=tys2} ->
Operator.compare op1 op2 @@< fun () ->
Mark.compare Operator.compare op1 op2 @@< fun () ->
List.compare compare args1 args2 @@< fun () ->
List.compare Type.compare tys1 tys2
| EArray a1, EArray a2 ->
@ -845,7 +847,8 @@ let remove_logging_calls e =
let rec f e =
let e, m = map ~f ~op:Fun.id e in
( Bindlib.box_apply
(function EAppOp { op = Log _; args = [(arg, _)]; _ } -> arg | e -> e)
(function
| EAppOp { op = Log _, _; args = [(arg, _)]; _ } -> arg | e -> e)
e,
m )
in

4
compiler/shared_ast/expr.mli
View File

@ -85,7 +85,7 @@ val eassert :
val efatalerror : Runtime.error -> 'm mark -> (< .. >, 'm) boxed_gexpr
val eappop :
op:'a operator ->
op:'a operator Mark.pos ->
args:('a, 'm) boxed_gexpr list ->
tys:typ list ->
'm mark ->
@ -243,7 +243,7 @@ val untype : ('a, 'm) gexpr -> ('a, untyped) boxed_gexpr
val map :
?typ:(typ -> typ) ->
?op:('a operator -> 'b operator) ->
?op:('a operator Mark.pos -> 'b operator Mark.pos) ->
f:(('a, 'm1) gexpr -> ('b, 'm2) boxed_gexpr) ->
(('a, 'b, 'm1) base_gexpr, 'm2) marked ->
('b, 'm2) boxed_gexpr

33
compiler/shared_ast/interpreter.ml
View File

@ -62,7 +62,8 @@ let print_log lang entry infos pos e =
(* Todo: this should be handled early when resolving overloads. Here we have
proper structural equality, but the OCaml backend for example uses the
builtin equality function instead of this. *)
let handle_eq evaluate_operator m lang e1 e2 =
let handle_eq pos evaluate_operator m lang e1 e2 =
let eq_eval = evaluate_operator (Eq, pos) m lang in
let open Runtime.Oper in
match e1, e2 with
| ELit LUnit, ELit LUnit -> true
@ -77,7 +78,7 @@ let handle_eq evaluate_operator m lang e1 e2 =
try
List.for_all2
(fun e1 e2 ->
match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with
match Mark.remove (eq_eval [e1; e2]) with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
@ -87,7 +88,7 @@ let handle_eq evaluate_operator m lang e1 e2 =
StructName.equal s1 s2
&& StructField.Map.equal
(fun e1 e2 ->
match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with
match Mark.remove (eq_eval [e1; e2]) with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
@ -98,7 +99,7 @@ let handle_eq evaluate_operator m lang e1 e2 =
EnumName.equal en1 en2
&& EnumConstructor.equal i1 i2
&&
match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with
match Mark.remove (eq_eval [e1; e2]) with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *)
@ -108,12 +109,12 @@ let handle_eq evaluate_operator m lang e1 e2 =
(* Call-by-value: the arguments are expected to be already evaluated here *)
let rec evaluate_operator
evaluate_expr
(op : < overloaded : no ; .. > operator)
((op, opos) : < overloaded : no ; .. > operator Mark.pos)
m
lang
args =
let pos = Expr.mark_pos m in
let rpos = Expr.pos_to_runtime pos in
let rpos = Expr.pos_to_runtime opos in
let err () =
Message.error
~extra_pos:
@ -121,7 +122,7 @@ let rec evaluate_operator
( Format.asprintf "Operator (value %a):"
(Print.operator ~debug:true)
op,
pos );
opos );
]
@ List.mapi
(fun i arg ->
@ -151,7 +152,7 @@ let rec evaluate_operator
Mark.remove e'
| (ToClosureEnv | FromClosureEnv), _ -> err ()
| Eq, [(e1, _); (e2, _)] ->
ELit (LBool (handle_eq (evaluate_operator evaluate_expr) m lang e1 e2))
ELit (LBool (handle_eq opos (evaluate_operator evaluate_expr) m lang e1 e2))
| Map, [f; (EArray es, _)] ->
EArray
(List.map
@ -814,12 +815,13 @@ and partially_evaluate_expr_for_assertion_failure_message :
args = [e1; e2];
tys;
op =
( And | Or | Xor | Eq | Lt_int_int | Lt_rat_rat | Lt_mon_mon
| Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon
| Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon
| Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon
| Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon
| Eq_dur_dur | Eq_dat_dat ) as op;
( ( And | Or | Xor | Eq | Lt_int_int | Lt_rat_rat | Lt_mon_mon
| Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon
| Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon
| Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon
| Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon
| Eq_dur_dur | Eq_dat_dat ),
_ ) as op;
} ->
( EAppOp
{
@ -950,7 +952,8 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr
~name:Expr.option_enum mark_e)
ty_in (Expr.mark_pos mark_e);
Expr.eappop ~op:Operator.ToClosureEnv
Expr.eappop
~op:(Operator.ToClosureEnv, pos)
~args:[Expr.etuple [] mark_e]
~tys:[TClosureEnv, pos]
mark_e;

2
compiler/shared_ast/interpreter.mli
View File

@ -22,7 +22,7 @@ open Definitions
val evaluate_operator :
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
'a operator ->
'a operator Mark.pos ->
'm mark ->
Global.backend_lang ->
('a, 'm) gexpr list ->

96
compiler/shared_ast/operator.ml
View File

@ -330,36 +330,39 @@ let equal t1 t2 = compare t1 t2 = 0
let kind_dispatch :
type a.
polymorphic:(< polymorphic : yes ; .. > t -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t -> 'b) ->
?resolved:(< resolved : yes ; .. > t -> 'b) ->
a t ->
polymorphic:(< polymorphic : yes ; .. > t Mark.pos -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t Mark.pos -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t Mark.pos -> 'b) ->
?resolved:(< resolved : yes ; .. > t Mark.pos -> 'b) ->
a t Mark.pos ->
'b =
fun ~polymorphic ~monomorphic ?(overloaded = fun _ -> assert false)
?(resolved = fun _ -> assert false) op ->
match op with
| ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | And
| Or | Xor ) as op ->
| ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| And | Or | Xor ),
_ ) as op ->
monomorphic op
| ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold
| HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ) as op
->
| ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold
| HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ),
_ ) as op ->
polymorphic op
| ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt
| Gte ) as op ->
| ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt
| Gte ),
_ ) as op ->
overloaded op
| ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon
| ToMoney_rat | Round_rat | Round_mon | Add_int_int | Add_rat_rat
| Add_mon_mon | Add_dat_dur _ | Add_dur_dur | Sub_int_int | Sub_rat_rat
| Sub_mon_mon | Sub_dat_dat | Sub_dat_dur | Sub_dur_dur | Mult_int_int
| Mult_rat_rat | Mult_mon_rat | Mult_dur_int | Div_int_int | Div_rat_rat
| Div_mon_mon | Div_mon_rat | Div_dur_dur | Lt_int_int | Lt_rat_rat
| Lt_mon_mon | Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat
| Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat
| Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat
| Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat
| Eq_mon_mon | Eq_dat_dat | Eq_dur_dur ) as op ->
| ( ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon
| ToMoney_rat | Round_rat | Round_mon | Add_int_int | Add_rat_rat
| Add_mon_mon | Add_dat_dur _ | Add_dur_dur | Sub_int_int | Sub_rat_rat
| Sub_mon_mon | Sub_dat_dat | Sub_dat_dur | Sub_dur_dur | Mult_int_int
| Mult_rat_rat | Mult_mon_rat | Mult_dur_int | Div_int_int | Div_rat_rat
| Div_mon_mon | Div_mon_rat | Div_dur_dur | Lt_int_int | Lt_rat_rat
| Lt_mon_mon | Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat
| Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat
| Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat
| Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat
| Eq_mon_mon | Eq_dat_dat | Eq_dur_dur ),
_ ) as op ->
resolved op
type 'a no_overloads =
@ -371,22 +374,23 @@ type 'a no_overloads =
as
'a
let translate (t : 'a no_overloads t) : 'b no_overloads t =
let translate (t : 'a no_overloads t Mark.pos) : 'b no_overloads t Mark.pos =
match t with
| ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | And
| Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq | Map
| Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat | Minus_mon
| Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat | Round_mon
| Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _ | Add_dur_dur
| Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur
| Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur
| Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur
| Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur
| Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur
| Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur
| Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur
| FromClosureEnv | ToClosureEnv ) as op ->
| ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| And | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq
| Map | Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat
| Minus_mon | Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat
| Round_mon | Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _
| Add_dur_dur | Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat
| Sub_dat_dur | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat
| Mult_dur_int | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat
| Div_dur_dur | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat
| Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat
| Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat
| Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat
| Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat
| Eq_dur_dur | FromClosureEnv | ToClosureEnv ),
_ ) as op ->
op
let monomorphic_type ((op : monomorphic t), pos) =
@ -537,8 +541,11 @@ let resolve_overload_aux (op : overloaded t) (operands : typ_lit list) :
_ ) ->
raise Not_found
let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
< resolved : yes ; .. > t * [ `Straight | `Reversed ] =
let resolve_overload
ctx
((op, pos) : overloaded t Mark.pos)
(operands : typ list) :
< resolved : yes ; .. > t Mark.pos * [ `Straight | `Reversed ] =
try
let operands =
List.map
@ -546,11 +553,12 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
match Mark.remove t with TLit tl -> tl | _ -> raise Not_found)
operands
in
resolve_overload_aux (Mark.remove op) operands
let op, direction = resolve_overload_aux op operands in
(op, pos), direction
with Not_found ->
Message.error
~extra_pos:
(("", Mark.get op)
(("", pos)
:: List.map
(fun ty ->
( Format.asprintf "Type %a coming from expression:"
@ -559,7 +567,7 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
operands)
"I don't know how to apply operator %a on types %a"
(Print.operator ~debug:true)
(Mark.remove op)
op
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf " and@ ")
(Print.typ ctx))
@ -567,4 +575,4 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
let overload_type ctx (op : overloaded t Mark.pos) (operands : typ list) : typ =
let rop = fst (resolve_overload ctx op operands) in
resolved_type (Mark.copy op rop)
resolved_type rop

14
compiler/shared_ast/operator.mli
View File

@ -43,11 +43,11 @@ val name : 'a t -> string
symbols, e.g. [+$]. *)
val kind_dispatch :
polymorphic:(< polymorphic : yes ; .. > t -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t -> 'b) ->
?resolved:(< resolved : yes ; .. > t -> 'b) ->
'a t ->
polymorphic:(< polymorphic : yes ; .. > t Mark.pos -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t Mark.pos -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t Mark.pos -> 'b) ->
?resolved:(< resolved : yes ; .. > t Mark.pos -> 'b) ->
'a t Mark.pos ->
'b
(** Calls one of the supplied functions depending on the kind of the operator *)
@ -60,7 +60,7 @@ type 'a no_overloads =
as
'a
val translate : 'a no_overloads t -> 'b no_overloads t
val translate : 'a no_overloads t Mark.pos -> 'b no_overloads t Mark.pos
(** An identity function that allows translating an operator between different
passes that don't change operator types *)
@ -84,7 +84,7 @@ val resolve_overload :
decl_ctx ->
overloaded t Mark.pos ->
typ list ->
< resolved : yes ; .. > t * [ `Straight | `Reversed ]
< resolved : yes ; .. > t Mark.pos * [ `Straight | `Reversed ]
(** Some overloads are sugar for an operation with reversed operands, e.g.
[TRat * TMoney] is using [mult_mon_rat]. [`Reversed] is returned to signify
this case. *)

54
compiler/shared_ast/optimizations.ml
View File

@ -97,15 +97,15 @@ let rec optimize_expr :
the matches and the log calls are not preserved, which would be a good
property *)
match Mark.remove e with
| EAppOp { op = Not; args = [(ELit (LBool b), _)]; _ } ->
| EAppOp { op = Not, _; args = [(ELit (LBool b), _)]; _ } ->
(* reduction of logical not *)
ELit (LBool (not b))
| EAppOp { op = Or; args = [(ELit (LBool b), _); (e, _)]; _ }
| EAppOp { op = Or; args = [(e, _); (ELit (LBool b), _)]; _ } ->
| EAppOp { op = Or, _; args = [(ELit (LBool b), _); (e, _)]; _ }
| EAppOp { op = Or, _; args = [(e, _); (ELit (LBool b), _)]; _ } ->
(* reduction of logical or *)
if b then ELit (LBool true) else e
| EAppOp { op = And; args = [(ELit (LBool b), _); (e, _)]; _ }
| EAppOp { op = And; args = [(e, _); (ELit (LBool b), _)]; _ } ->
| EAppOp { op = And, _; args = [(ELit (LBool b), _); (e, _)]; _ }
| EAppOp { op = And, _; args = [(e, _); (ELit (LBool b), _)]; _ } ->
(* reduction of logical and *)
if b then e else ELit (LBool false)
| EMatch { e = EInj { e = e'; cons; name = n' }, _; cases; name = n }
@ -140,15 +140,12 @@ let rec optimize_expr :
match Mark.remove b1, Mark.remove e2 with
| EAbs { binder = b1; _ }, EAbs { binder = b2; tys } -> (
let v1, e1 = Bindlib.unmbind b1 in
let[@warning "-8"] [| v1 |] = v1 in
match Mark.remove e1 with
| EInj { e = e1; _ } ->
| EInj { e = e1, _; _ } ->
Some
(Expr.unbox
(Expr.make_abs [| v1 |]
(Expr.rebox
(Bindlib.msubst b2
([e1] |> List.map fst |> Array.of_list)))
(Expr.make_abs v1
(Expr.rebox (Bindlib.msubst b2 [| e1 |]))
tys (Expr.pos e2)))
| _ -> assert false)
| _ -> assert false)
@ -198,13 +195,13 @@ let rec optimize_expr :
Mark.remove cons
| ( [],
( ( ELit (LBool false)
| EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ),
| EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ),
_ ) ) ->
(* No exceptions and condition false *)
EEmpty
| ( [except],
( ( ELit (LBool false)
| EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ),
| EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ),
_ ) ) ->
(* Single exception and condition false *)
Mark.remove except
@ -213,7 +210,7 @@ let rec optimize_expr :
{
cond =
( ELit (LBool true), _
| EAppOp { op = Log _; args = [(ELit (LBool true), _)]; _ }, _ );
| EAppOp { op = Log _, _; args = [(ELit (LBool true), _)]; _ }, _ );
etrue;
_;
} ->
@ -222,7 +219,7 @@ let rec optimize_expr :
{
cond =
( ( ELit (LBool false)
| EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ),
| EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ),
_ );
efalse;
_;
@ -233,32 +230,37 @@ let rec optimize_expr :
cond;
etrue =
( ( ELit (LBool btrue)
| EAppOp { op = Log _; args = [(ELit (LBool btrue), _)]; _ } ),
| EAppOp { op = Log _, _; args = [(ELit (LBool btrue), _)]; _ } ),
_ );
efalse =
( ( ELit (LBool bfalse)
| EAppOp { op = Log _; args = [(ELit (LBool bfalse), _)]; _ } ),
| EAppOp { op = Log _, _; args = [(ELit (LBool bfalse), _)]; _ }
),
_ );
} ->
if btrue && not bfalse then Mark.remove cond
else if (not btrue) && bfalse then
EAppOp
{ op = Not; tys = [TLit TBool, Expr.mark_pos mark]; args = [cond] }
{
op = Not, Expr.mark_pos mark;
tys = [TLit TBool, Expr.mark_pos mark];
args = [cond];
}
(* note: this last call eliminates the condition & might skip log calls
as well *)
else (* btrue = bfalse *) ELit (LBool btrue)
| EAppOp { op = Op.Fold; args = [_f; init; (EArray [], _)]; _ } ->
| EAppOp { op = Op.Fold, _; args = [_f; init; (EArray [], _)]; _ } ->
(*reduces a fold with an empty list *)
Mark.remove init
| EAppOp
{
op = Map;
op = (Map, _) as op;
args =
[
f1;
( EAppOp
{
op = Map;
op = Map, _;
args = [f2; ls];
tys = [_; ((TArray xty, _) as lsty)];
},
@ -286,7 +288,7 @@ let rec optimize_expr :
in
let fg = optimize_expr ctx (Expr.unbox fg) in
let mapl =
Expr.eappop ~op:Map
Expr.eappop ~op
~args:[fg; Expr.box ls]
~tys:[Expr.maybe_ty (Mark.get fg); lsty]
mark
@ -294,13 +296,13 @@ let rec optimize_expr :
Mark.remove (Expr.unbox mapl)
| EAppOp
{
op = Map;
op = Map, _;
args =
[
f1;
( EAppOp
{
op = Map2;
op = (Map2, _) as op;
args = [f2; ls1; ls2];
tys =
[
@ -339,7 +341,7 @@ let rec optimize_expr :
in
let fg = optimize_expr ctx (Expr.unbox fg) in
let mapl =
Expr.eappop ~op:Map2
Expr.eappop ~op
~args:[fg; Expr.box ls1; Expr.box ls2]
~tys:[Expr.maybe_ty (Mark.get fg); ls1ty; ls2ty]
mark
@ -347,7 +349,7 @@ let rec optimize_expr :
Mark.remove (Expr.unbox mapl)
| EAppOp
{
op = Op.Fold;
op = Op.Fold, _;
args = [f; init; (EArray [e'], _)];
tys = [_; tinit; (TArray tx, _)];
} ->

20
compiler/shared_ast/print.ml
View File

@ -370,7 +370,7 @@ module Precedence = struct
match Mark.remove e with
| ELit _ -> Contained (* Todo: unop if < 0 *)
| EAppOp { op; _ } -> (
match op with
match Mark.remove op with
| Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| Length | Log _ | Minus | Minus_int | Minus_rat | Minus_mon | Minus_dur
| ToRat | ToRat_int | ToRat_mon | ToMoney | ToMoney_rat | Round
@ -571,16 +571,16 @@ module ExprGen (C : EXPR_PARAM) = struct
Format.pp_close_box fmt ();
punctuation fmt ")"))
xs_tau punctuation "→" (rhs expr) body
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2]; _ } ->
| EAppOp { op = ((Map | Filter) as op), _; args = [arg1; arg2]; _ } ->
Format.fprintf fmt "@[<hv 2>%a %a@ %a@]" operator op (lhs exprc) arg1
(rhs exprc) arg2
| EAppOp { op = Log _ as op; args = [arg1]; _ } ->
| EAppOp { op = (Log _ as op), _; args = [arg1]; _ } ->
Format.fprintf fmt "@[<hv 0>%a@ %a@]" operator op (rhs exprc) arg1
| EAppOp { op = op0; args = [_; _]; _ } ->
| EAppOp { op = op0, _; args = [_; _]; _ } ->
let prec = Precedence.expr e in
let rec pr colors fmt = function
(* Flatten sequences of the same associative op *)
| EAppOp { op; args = [arg1; arg2]; _ }, _ when op = op0 -> (
| EAppOp { op = op, _; args = [arg1; arg2]; _ }, _ when op = op0 -> (
(match prec with
| Op (And | Or | Mul | Add | Div | Sub) -> lhs pr fmt arg1
| _ -> lhs exprc fmt arg1);
@ -595,9 +595,9 @@ module ExprGen (C : EXPR_PARAM) = struct
Format.pp_open_hvbox fmt 0;
pr colors fmt e;
Format.pp_close_box fmt ()
| EAppOp { op; args = [arg1]; _ } ->
| EAppOp { op = op, _; args = [arg1]; _ } ->
Format.fprintf fmt "@[<hv 2>%a@ %a@]" operator op (rhs exprc) arg1
| EAppOp { op; args; _ } ->
| EAppOp { op = op, _; args; _ } ->
Format.fprintf fmt "@[<hv 2>%a@ %a@]" operator op
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
@ -761,7 +761,7 @@ module ExprConciseParam = struct
let lit = lit
let rec pre_map : type a. (a, 't) gexpr -> (a, 't) gexpr = function
| EAppOp { op = Log _; args = [e]; _ }, _ -> pre_map e
| EAppOp { op = Log _, _; args = [e]; _ }, _ -> pre_map e
| e -> e
end
@ -951,8 +951,8 @@ let program ?(debug = false) fmt p =
(* This function is re-exported from module [Expr], but defined here where it's
first needed *)
let rec skip_wrappers : type a. (a, 'm) gexpr -> (a, 'm) gexpr = function
| EAppOp { op = Log _; args = [e]; tys = _ }, _ -> skip_wrappers e
| EApp { f = EAppOp { op = Log _; args = [f]; _ }, _; args; tys }, m ->
| EAppOp { op = Log _, _; args = [e]; tys = _ }, _ -> skip_wrappers e
| EApp { f = EAppOp { op = Log _, _; args = [f]; _ }, _; args; tys }, m ->
skip_wrappers (EApp { f; args; tys }, m)
| EErrorOnEmpty e, _ -> skip_wrappers e
| EDefault { excepts = []; just = ELit (LBool true), _; cons = e }, _ ->

25
compiler/shared_ast/typing.ml
View File

@ -354,13 +354,11 @@ let polymorphic_op_return_type
let resolve_overload_ret_type
~flags
(ctx : A.decl_ctx)
e
(op : Operator.overloaded A.operator)
_e
(op : Operator.overloaded A.operator Mark.pos)
tys : unionfind_typ =
let op_ty =
Operator.overload_type ctx
(Mark.add (Expr.pos e) op)
(List.map (typ_to_ast ~flags) tys)
Operator.overload_type ctx op (List.map (typ_to_ast ~flags) tys)
in
ast_to_typ (Type.arrow_return op_ty)
@ -887,17 +885,14 @@ and typecheck_expr_top_down :
let t_args = List.map ast_to_typ tys in
let t_func = unionfind (TArrow (t_args, tau)) in
let args =
Operator.kind_dispatch op
Operator.kind_dispatch (Mark.set pos_e op)
~polymorphic:(fun op ->
(* Type the operator first, then right-to-left: polymorphic operators
are required to allow the resolution of all type variables this
way *)
if not env.flags.assume_op_types then
unify ctx e (polymorphic_op_type (Mark.add pos_e op)) t_func
else
unify ctx e
(polymorphic_op_return_type ctx e (Mark.add pos_e op) t_args)
tau;
unify ctx e (polymorphic_op_type op) t_func
else unify ctx e (polymorphic_op_return_type ctx e op t_args) tau;
List.rev_map2
(typecheck_expr_top_down ctx env)
(List.rev t_args) (List.rev args))
@ -908,15 +903,11 @@ and typecheck_expr_top_down :
args')
~monomorphic:(fun op ->
(* Here it doesn't matter but may affect the error messages *)
unify ctx e
(ast_to_typ (Operator.monomorphic_type (Mark.add pos_e op)))
t_func;
unify ctx e (ast_to_typ (Operator.monomorphic_type op)) t_func;
List.map2 (typecheck_expr_top_down ctx env) t_args args)
~resolved:(fun op ->
(* This case should not fail *)
unify ctx e
(ast_to_typ (Operator.resolved_type (Mark.add pos_e op)))
t_func;
unify ctx e (ast_to_typ (Operator.resolved_type op)) t_func;
List.map2 (typecheck_expr_top_down ctx env) t_args args)
in
(* All operator applications are monomorphised at this point *)

4
compiler/surface/ast.ml
View File

@ -145,6 +145,7 @@ and literal =
| LDate of literal_date
and collection_op =
| Member of { element : expression }
| Exists of { predicate : lident Mark.pos list * expression }
| Forall of { predicate : lident Mark.pos list * expression }
| Map of { f : lident Mark.pos list * expression }
@ -175,8 +176,7 @@ and naked_expression =
| IfThenElse of expression * expression * expression
| Binop of binop Mark.pos * expression * expression
| Unop of unop Mark.pos * expression
| CollectionOp of collection_op * expression
| MemCollection of expression * expression
| CollectionOp of collection_op Mark.pos * expression
| TestMatchCase of expression * match_case_pattern Mark.pos
| FunCall of expression * expression list
| ScopeCall of

43
compiler/surface/parser.mly
View File

@ -232,25 +232,26 @@ let naked_expression ==
RBRACE ; {
StructReplace (e, fields)
}
| e1 = expression ;
CONTAINS ;
e2 = expression ; {
MemCollection (e2, e1)
| coll = expression ;
pos = pos(CONTAINS) ;
element = expression ; {
CollectionOp ((Member { element }, pos), coll)
} %prec apply
| SUM ; typ = addpos(primitive_typ) ;
| pos = pos(SUM) ; typ = addpos(primitive_typ) ;
OF ; coll = expression ; {
CollectionOp (AggregateSum { typ = Mark.remove typ }, coll)
CollectionOp ((AggregateSum { typ = Mark.remove typ }, pos), coll)
} %prec apply
| f = expression ;
FOR ; i = mbinder ;
pos = pos(FOR) ; i = mbinder ;
AMONG ; coll = expression ; {
CollectionOp (Map {f = i, f}, coll)
CollectionOp ((Map {f = i, f}, pos), coll)
} %prec apply
| max = minmax ;
| maxp = addpos(minmax) ;
OF ; coll = expression ;
OR ; IF ; LIST_EMPTY ; THEN ;
default = expression ; {
CollectionOp (AggregateExtremum { max; default }, coll)
let max, pos = maxp in
CollectionOp ((AggregateExtremum { max; default }, pos), coll)
} %prec apply
| op = addpos(unop) ; e = expression ; {
Unop (op, e)
@ -260,15 +261,15 @@ let naked_expression ==
e2 = expression ; {
Binop (binop, e1, e2)
}
| EXISTS ; i = mbinder ;
| pos = pos(EXISTS) ; i = mbinder ;
AMONG ; coll = expression ;
SUCH ; THAT ; predicate = expression ; {
CollectionOp (Exists {predicate = i, predicate}, coll)
CollectionOp ((Exists {predicate = i, predicate}, pos), coll)
} %prec let_expr
| FOR ; ALL ; i = mbinder ;
| pos = pos(FOR) ; ALL ; i = mbinder ;
AMONG ; coll = expression ;
WE_HAVE ; predicate = expression ; {
CollectionOp (Forall {predicate = i, predicate}, coll)
CollectionOp ((Forall {predicate = i, predicate}, pos), coll)
} %prec let_expr
| MATCH ; e = expression ;
WITH ;
@ -285,23 +286,23 @@ let naked_expression ==
IN ; e2 = expression ; {
LetIn (ids, e1, e2)
} %prec let_expr
| LIST; ids = mbinder ;
| pos = pos(LIST); ids = mbinder ;
AMONG ; coll = expression ;
SUCH ; THAT ; f = expression ; {
CollectionOp (Filter {f = ids, f}, coll)
CollectionOp ((Filter {f = ids, f}, pos), coll)
} %prec top_expr
| fmap = expression ;
FOR ; i = mbinder ;
pfor = pos(FOR) ; i = mbinder ;
AMONG ; coll = expression ;
SUCH ; THAT ; ffilt = expression ; {
CollectionOp (Map {f = i, fmap}, (CollectionOp (Filter {f = i, ffilt}, coll), Pos.from_lpos $loc))
psuch = pos(SUCH) ; THAT ; ffilt = expression ; {
CollectionOp ((Map {f = i, fmap}, pfor), (CollectionOp ((Filter {f = i, ffilt}, psuch), coll), Pos.from_lpos $loc))
} %prec top_expr
| CONTENT; OF; ids = mbinder ;
| pos = pos(CONTENT); OF; ids = mbinder ;
AMONG ; coll = expression ;
SUCH ; THAT ; f = expression ;
IS ; max = minmax ;
OR ; IF ; LIST_EMPTY ; THEN ; default = expression ; {
CollectionOp (AggregateArgExtremum { max; default; f = ids, f }, coll)
CollectionOp ((AggregateArgExtremum { max; default; f = ids, f }, pos), coll)
} %prec top_expr

14
compiler/verification/conditions.ml
View File

@ -40,7 +40,7 @@ let rec conjunction_exprs (exprs : typed expr list) (mark : typed mark) :
| hd :: tl ->
( EAppOp
{
op = And;
op = And, Expr.mark_pos mark;
tys = [TLit TBool, Expr.pos hd; TLit TBool, Expr.pos hd];
args = [hd; conjunction_exprs tl mark];
},
@ -54,7 +54,7 @@ let conjunction (args : vc_return list) (mark : typed mark) : vc_return =
(fun acc arg ->
( EAppOp
{
op = And;
op = And, Expr.mark_pos mark;
tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg];
args = [arg; acc];
},
@ -62,7 +62,13 @@ let conjunction (args : vc_return list) (mark : typed mark) : vc_return =
acc list
let negation (arg : vc_return) (mark : typed mark) : vc_return =
EAppOp { op = Not; tys = [TLit TBool, Expr.pos arg]; args = [arg] }, mark
( EAppOp
{
op = Not, Expr.mark_pos mark;
tys = [TLit TBool, Expr.pos arg];
args = [arg];
},
mark )
let disjunction (args : vc_return list) (mark : typed mark) : vc_return =
let acc, list =
@ -72,7 +78,7 @@ let disjunction (args : vc_return list) (mark : typed mark) : vc_return =
(fun (acc : vc_return) arg ->
( EAppOp
{
op = Or;
op = Or, Expr.mark_pos mark;
tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg];
args = [arg; acc];
},

18
compiler/verification/z3backend.real.ml
View File

@ -432,15 +432,15 @@ let is_leap_year = Runtime.is_leap_year
(** [translate_op] returns the Z3 expression corresponding to the application of
[op] to the arguments [args] **)
let rec translate_op :
context -> dcalc operator -> 'm expr list -> context * Expr.expr =
fun ctx op args ->
context -> dcalc operator Mark.pos -> 'm expr list -> context * Expr.expr =
fun ctx (op, pos) args ->
let ill_formed () =
Format.kasprintf failwith
"[Z3 encoding] Ill-formed operator application: %a" Shared_ast.Expr.format
(Shared_ast.Expr.eappop ~op
(Shared_ast.Expr.eappop ~op:(op, pos)
~args:(List.map Shared_ast.Expr.untype args)
~tys:[]
(Untyped { pos = Pos.no_pos })
(Untyped { pos })
|> Shared_ast.Expr.unbox)
in
let app f =
@ -458,7 +458,7 @@ let rec translate_op :
failwith "[Z3 encoding] ternary operator application not supported"
(* Special case for GetYear comparisons *)
| ( Lt_int_int,
[(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
[(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
let n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in
let e2 =
@ -469,7 +469,7 @@ let rec translate_op :
days *)
ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2
| ( Lte_int_int,
[(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
[(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
let ctx, e1 = translate_expr ctx e1 in
let nb_days = if is_leap_year n then 365 else 364 in
let n = Runtime.integer_to_int n in
@ -483,7 +483,7 @@ let rec translate_op :
in
ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2
| ( Gt_int_int,
[(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
[(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
let ctx, e1 = translate_expr ctx e1 in
let nb_days = if is_leap_year n then 365 else 364 in
let n = Runtime.integer_to_int n in
@ -497,7 +497,7 @@ let rec translate_op :
in
ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2
| ( Gte_int_int,
[(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
[(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) ->
let n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in
let e2 =
@ -507,7 +507,7 @@ let rec translate_op :
be directly translated as >= in the Z3 encoding using the number of
days *)
ctx, Arithmetic.mk_ge ctx.ctx_z3 e1 e2
| Eq, [(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ->
| Eq, [(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ->
let n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in
let min_date =

33
tests/arithmetic/bad/division_by_zero.catala_en
View File

@ -32,54 +32,39 @@ scope Money:
```catala-test-inline
$ catala Interpret -s Dec
$ catala test-scope Dec
[ERROR] Error during evaluation: division by zero.
┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:20.23-20.30:
┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:20.26-20.27:
└──┐
20 │ definition i equals 1. / 0.
│ ‾‾‾‾‾‾‾
└┬ `Division_by_zero` exception management
└─ with decimals
#return code 123#
```
Fixme: the following should give the same result as above, but the optimisation pass propagates the position surrounding the `ErrorOnEmpty` and loses the position of the actual division expression which was in the `cons` of the default term. Unfortunately this is non-trivial due to the bindlib boxing tricks.
```catala-test-inline
$ catala Interpret -O -s Dec
[ERROR] Error during evaluation: division by zero.
┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:17.10-17.11:
└──┐
17 │ output i content decimal
│ ‾
│ ‾
└┬ `Division_by_zero` exception management
└─ with decimals
#return code 123#
```
```catala-test-inline
$ catala interpret -s Int
$ catala test-scope Int
[ERROR] Error during evaluation: division by zero.
┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:10.23-10.28:
┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:10.25-10.26:
└──┐
10 │ definition i equals 1 / 0
│ ‾‾‾‾‾
│ ‾
└┬ `Division_by_zero` exception management
└─ with integers
#return code 123#
```
```catala-test-inline
$ catala Interpret -s Money
$ catala test-scope Money
[ERROR] Error during evaluation: division by zero.
┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:30.23-30.35:
┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:30.29-30.30:
└──┐
30 │ definition i equals $10.0 / $0.0
│ ‾‾‾‾‾‾‾‾‾‾‾‾
│ ‾
└┬ `Division_by_zero` exception management
└─ with money
#return code 123#

16
tests/date/bad/uncomparable_duration.catala_en
View File

@ -49,10 +49,10 @@ $ catala interpret -s Ge
[ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days).
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:40.23-40.39:
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:40.31-40.33:
└──┐
40 │ definition d equals 1 month >= 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
│ ‾‾
└┬ `UncomparableDurations` exception management
└─ `>=` operator
#return code 123#
@ -63,10 +63,10 @@ $ catala interpret -s Gt
[ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days).
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:30.23-30.38:
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:30.31-30.32:
└──┐
30 │ definition d equals 1 month > 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
│ ‾
└┬ `UncomparableDurations` exception management
└─ `<=` operator
#return code 123#
@ -77,10 +77,10 @@ $ catala interpret -s Le
[ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days).
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:20.23-20.39:
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:20.31-20.33:
└──┐
20 │ definition d equals 1 month <= 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
│ ‾‾
└┬ `UncomparableDurations` exception management
└─ `<=` operator
#return code 123#
@ -91,10 +91,10 @@ $ catala interpret -s Lt
[ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days).
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:10.23-10.38:
┌─⯈ tests/date/bad/uncomparable_duration.catala_en:10.31-10.32:
└──┐
10 │ definition d equals 1 month < 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
│ ‾
└┬ `UncomparableDurations` exception management
└─ `<` operator
#return code 123#

2
tests/modules/good/output/mod_def.ml
View File

@ -66,7 +66,7 @@ let half_ : integer -> decimal =
fun (x_: integer) ->
o_div_int_int
{filename="tests/modules/good/mod_def.catala_en";
start_line=21; start_column=10; end_line=21; end_column=15;
start_line=21; start_column=12; end_line=21; end_column=13;
law_headings=["Test modules + inclusions 1"]} x_ (integer_of_string
"2")