CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-16 14:57:13 +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 let m = mark_tany (Mark.get e) (Expr.pos e) in
if Global.options.trace then 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 else e
(* In a list of exceptions, it is normally an error if more than a single one (* 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 let v, _ = TopdefName.Map.find (Mark.remove name) ctx.toplevel_vars in
Expr.evar v m Expr.evar v m
else Expr.eexternal ~name:(Mark.map (fun n -> External_value n) name) 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 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 _ | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _
| ETupleAccess _ | EInj _ | EFatalError _ | EEmpty | EErrorOnEmpty _ | ETupleAccess _ | EInj _ | EFatalError _ | EEmpty | EErrorOnEmpty _
| EArray _ | EIfThenElse _ | EAppOp _ ) as e -> | EArray _ | EIfThenElse _ | EAppOp _ ) as e ->

81
compiler/desugared/from_surface.ml
View File

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

3
compiler/lcalc/compile_with_exceptions.ml
View File

@ -51,7 +51,8 @@ let rec translate_default
let exceptions = let exceptions =
List.map (fun except -> Expr.thunk_term (translate_expr except)) exceptions List.map (fun except -> Expr.thunk_term (translate_expr except)) exceptions
in in
Expr.eappop ~op:Op.HandleDefault Expr.eappop
~op:(Op.HandleDefault, Expr.pos cons)
~tys: ~tys:
[ [
TArray (TArrow ([TLit TUnit, pos], (TAny, pos)), pos), pos; 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 pos = Expr.mark_pos mark_default in
let exceptions = List.map translate_expr exceptions in let exceptions = List.map translate_expr exceptions in
let exceptions_and_cons_ty = Expr.maybe_ty mark_default 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: ~tys:
[ [
TArray exceptions_and_cons_ty, pos; 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 xs_tau format_expr body
| EApp | EApp
{ {
f = EAppOp { op = Log (BeginCall, info); args = [f]; _ }, _; f = EAppOp { op = Log (BeginCall, info), _; args = [f]; _ }, _;
args = [arg]; args = [arg];
_; _;
} }
when Global.options.trace -> when Global.options.trace ->
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
format_with_parens f format_with_parens arg 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 -> when Global.options.trace ->
Format.fprintf fmt Format.fprintf fmt
"(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)" "(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_io_output typ_embedding_name
(var_def_info.log_typ, Pos.no_pos) (var_def_info.log_typ, Pos.no_pos)
format_with_parens arg1 format_with_parens arg1
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1]; _ } | EAppOp { op = Log (PosRecordIfTrueBool, _), _; args = [arg1]; _ }
when Global.options.trace -> when Global.options.trace ->
let pos = Expr.pos e in let pos = Expr.pos e in
Format.fprintf fmt 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_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_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) format_with_parens arg1 (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 -> when Global.options.trace ->
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
format_with_parens arg1 format_with_parens arg1
| EAppOp { op = Log _; args = [arg1]; _ } -> | EAppOp { op = Log _, _; args = [arg1]; _ } ->
Format.fprintf fmt "%a" format_with_parens arg1 Format.fprintf fmt "%a" format_with_parens arg1
| EAppOp | EAppOp
{ {
op = (HandleDefault | HandleDefaultOpt) as op; op = ((HandleDefault | HandleDefaultOpt) as op), _;
args = (EArray excs, _) :: _ as args; 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 Format.fprintf fmt
"@[<hov 2> if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@]" "@[<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 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) Format.fprintf fmt "@[<hov 2>%s@ %t%a@]" (Operator.name op)
(fun ppf -> (fun ppf ->
match op with match op with
| Map2 | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | 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 | Div_dur_dur | Lt_dur_dur | Lte_dur_dur | Gt_dur_dur | Gte_dur_dur
| Eq_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 (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") ~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 | Op.Gte_dur_dur -> Some Op.Lt_dur_dur
| _ -> None | _ -> None
let rec bool_negation e = let rec bool_negation pos e =
match Expr.skip_wrappers e with match Expr.skip_wrappers e with
| ELit (LBool true), m -> ELit (LBool false), m | ELit (LBool true), m -> ELit (LBool false), m
| ELit (LBool false), m -> ELit (LBool true), m | ELit (LBool false), m -> ELit (LBool true), m
| EAppOp { op = Op.Not; args = [(e, _)] }, m -> e, m | EAppOp { op = Op.Not, _; args = [(e, _)] }, m -> e, m
| (EAppOp { op; tys; args = [e1; e2] }, m) as e -> ( | (EAppOp { op = op, opos; tys; args = [e1; e2] }, m) as e -> (
match op with match op with
| Op.And -> | 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 -> | 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 ) m )
| op -> ( | op -> (
match neg_op op with 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 -> | 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 )))
| (_, m) as e -> | (_, 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 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 let r, env1 = lazy_eval ctx env1 llevel e in
env_elt.reduced <- r, env1; env_elt.reduced <- r, env1;
r, Env.join env env1 r, Env.join env env1
| EAppOp { op; args; tys }, m -> ( | EAppOp { op = op, opos; args; tys }, m -> (
if if
(not llevel.eval_default) (not llevel.eval_default)
&& not (List.equal Expr.equal args [ELit LUnit, m]) && 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 let pos = Expr.mark_pos m in
( EAppOp ( EAppOp
{ {
op = Op.Eq_int_int; op = Op.Eq_int_int, opos;
tys = [TLit TInt, pos; TLit TInt, pos]; tys = [TLit TInt, pos; TLit TInt, pos];
args = 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; 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 (* We did a transformation (removing the outer operator), but further
evaluation may be needed to guarantee that [llevel] is reached *) evaluation may be needed to guarantee that [llevel] is reached *)
lazy_eval ctx env { llevel with eval_match = true } e 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 = let env, args =
List.fold_left_map 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, e)
env args env args
in 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 else
let renv = ref env in let renv = ref env in
(* Dirty workaround returning env and conds from evaluate_operator *) (* 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 e
in in
let e = 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 (* Default language to English but this should not raise any error
messages so we don't care. *) messages so we don't care. *)
args 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) ~extra_pos:(List.map (fun (e, _) -> "", Expr.pos e) excs)
"Conflicting exceptions") "Conflicting exceptions")
| EPureDefault e, _ -> lazy_eval ctx env llevel e | EPureDefault e, _ -> lazy_eval ctx env llevel e
| EIfThenElse { cond; etrue; efalse }, _ -> ( | EIfThenElse { cond; etrue; efalse }, m -> (
match eval_to_value env cond with match eval_to_value env cond with
| (ELit (LBool true), _), _ -> | (ELit (LBool true), _), _ ->
let condition = cond, env in let condition = cond, env in
let e, env = lazy_eval ctx env llevel etrue in let e, env = lazy_eval ctx env llevel etrue in
add_condition ~condition e, env add_condition ~condition e, env
| (ELit (LBool false), m), _ -> ( | (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 let e, env = lazy_eval ctx env llevel efalse in
match efalse with match efalse with
(* The negated condition is not added for nested [else if] to reduce (* 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 = let rec aux env g e =
(* lazy_eval ctx env (result_level base_vars) e *) (* lazy_eval ctx env (result_level base_vars) e *)
match Expr.skip_wrappers e with 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 aux env g arg
(* we skip conversions *) (* we skip conversions *)
| ELit l, _ -> | ELit l, _ ->
@ -659,8 +680,9 @@ let program_to_graph
in in
let e = Mark.set m (Expr.skip_wrappers e) in let e = Mark.set m (Expr.skip_wrappers e) in
match e with 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) aux parent (g, var_vertices, env0) (Mark.set m arg)
(* we skip conversions *) (* we skip conversions *)
| ELit l, _ -> | ELit l, _ ->
@ -698,7 +720,8 @@ let program_to_graph
let v = G.V.create e in let v = G.V.create e in
let g = G.add_vertex g v in let g = G.add_vertex g v in
(g, var_vertices, env), v)) (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 *) (* First argument (which is a function) is ignored *)
let v = G.V.create e in let v = G.V.create e in
let g = G.add_vertex g v in let g = G.add_vertex g v in
@ -707,7 +730,7 @@ let program_to_graph
in in
( (List.fold_left (fun g -> G.add_edge g v) g children, var_vertices, env), ( (List.fold_left (fun g -> G.add_edge g v) g children, var_vertices, env),
v ) v )
| EAppOp { op; args = [lhs; rhs]; _ }, _ -> | EAppOp { op = op, _; args = [lhs; rhs]; _ }, _ ->
let v = G.V.create e in let v = G.V.create e in
let g = G.add_vertex g v in let g = G.add_vertex g v in
let (g, var_vertices, env), lhs = 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 *) else (* Constants *)
[`Style `Filled; `Fillcolor 0x77aaff; `Shape `Note] [`Style `Filled; `Fillcolor 0x77aaff; `Shape `Note]
| EStruct _, _ | EArray _, _ -> [`Shape `Record] | EStruct _, _ | EArray _, _ -> [`Shape `Record]
| EAppOp { op; _ }, _ -> ( | EAppOp { op = op, _; _ }, _ -> (
match op_kind op with match op_kind op with
| `Sum | `Product | _ -> [`Shape `Box] (* | _ -> [] *)) | `Sum | `Product | _ -> [`Shape `Box] (* | _ -> [] *))
| _ -> []) | _ -> [])

2
compiler/scalc/ast.ml
View File

@ -61,7 +61,7 @@ and naked_expr =
| EArray of expr list | EArray of expr list
| ELit of lit | ELit of lit
| EApp of { f : expr; args : expr list } | 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 } | EExternal of { modname : VarName.t Mark.pos; name : string Mark.pos }
type stmt = 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) e1_stmts, (A.ETupleAccess { e1 = new_e1; index }, Expr.pos expr)
| EAppOp | EAppOp
{ {
op = Op.HandleDefaultOpt; op = Op.HandleDefaultOpt, _;
args = [_exceptions; _just; _cons]; args = [_exceptions; _just; _cons];
tys = _; tys = _;
} }
@ -275,7 +275,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
e_stmts e_stmts
| EFatalError err -> [SFatalError err, Expr.pos block_expr] | EFatalError err -> [SFatalError err, Expr.pos block_expr]
| EAppOp | EAppOp
{ op = Op.HandleDefaultOpt; tys = _; args = [exceptions; just; cons] } { op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] }
when ctxt.config.keep_special_ops -> when ctxt.config.keep_special_ops ->
let exceptions = let exceptions =
match Mark.remove exceptions with 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.fprintf fmt "@[<hov 2>%a@ %a@]" EnumConstructor.format cons
format_expr e format_expr e
| ELit l -> Print.lit fmt l | 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.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" (Print.operator ~debug) op
format_with_parens arg1 format_with_parens arg2 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 Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
(Print.operator ~debug) op format_with_parens arg2 (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 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.fprintf fmt "@[<hov 2>%a@ %a@]" (Print.operator ~debug) op
format_with_parens arg1 format_with_parens arg1
| EApp { f; args = [] } -> | EApp { f; args = [] } ->
@ -93,7 +93,7 @@ let rec format_expr
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens) format_with_parens)
args args
| EAppOp { op; args } -> | EAppOp { op = op, _; args } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" (Print.operator ~debug) op Format.fprintf fmt "@[<hov 2>%a@ %a@]" (Print.operator ~debug) op
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") ~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 failwith
"should not happen, array initialization is caught at the statement level" "should not happen, array initialization is caught at the statement level"
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l) | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } -> | EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos) Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1 (format_expression ctx) arg2 (format_expression ctx) arg2
| EAppOp { op; args = [arg1; arg2] } -> | EAppOp { op; args = [arg1; arg2] } ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op
(op, Pos.no_pos) (format_expression ctx) arg2 (format_expression ctx) arg2
| EAppOp { op = Not; args = [arg1] } -> | EAppOp { op = (Not, _) as op; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos) Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1
| EAppOp | 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]; args = [arg1];
} -> } ->
Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos) Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1
| EAppOp { op; args = [arg1] } -> | EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos) Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1 | EAppOp { op = (HandleDefaultOpt | HandleDefault), _; args = _ } ->
| EAppOp { op = HandleDefaultOpt | HandleDefault; args = _ } ->
failwith "should not happen because of keep_special_ops" failwith "should not happen because of keep_special_ops"
| EApp { f; args } -> | EApp { f; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f 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)) (format_expression ctx))
args args
| EAppOp { op; 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 (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx)) (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)) (fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es es
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l) | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } -> | EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos) Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1 (format_expression ctx) arg2 (format_expression ctx) arg2
| EAppOp { op; args = [arg1; arg2] } -> | EAppOp { op; args = [arg1; arg2] } ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op
(op, Pos.no_pos) (format_expression ctx) arg2 (format_expression ctx) arg2
| EApp | 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 -> when Global.options.trace ->
Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info
(format_expression ctx) f (format_expression ctx) arg (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 -> when Global.options.trace ->
Format.fprintf fmt Format.fprintf fmt
"log_variable_definition(%a,@ LogIO(input_io=InputIO.%s,@ \ "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") | Runtime.Reentrant -> "Reentrant")
(if var_def_info.log_io_output then "True" else "False") (if var_def_info.log_io_output then "True" else "False")
(format_expression ctx) arg1 (format_expression ctx) arg1
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1] } | EAppOp { op = Log (PosRecordIfTrueBool, _), _; args = [arg1] }
when Global.options.trace -> when Global.options.trace ->
let pos = Mark.get e in let pos = Mark.get e in
Format.fprintf fmt 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_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_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) (format_expression ctx) arg1 (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.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info
(format_expression ctx) arg1 (format_expression ctx) arg1
| EAppOp { op = Log _; args = [arg1] } -> | EAppOp { op = Log _, _; args = [arg1] } ->
Format.fprintf fmt "%a" (format_expression ctx) arg1 Format.fprintf fmt "%a" (format_expression ctx) arg1
| EAppOp { op = Not; args = [arg1] } -> | EAppOp { op = (Not, _) as op; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos) Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1
| EAppOp | 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]; args = [arg1];
} -> } ->
Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos) Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1
| EAppOp { op; args = [arg1] } -> | EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos) Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1 | EAppOp { op = ((HandleDefault | HandleDefaultOpt), _) as op; args } ->
| EAppOp { op = (HandleDefault | HandleDefaultOpt) as op; args } ->
let pos = Mark.get e in let pos = Mark.get e in
Format.fprintf fmt Format.fprintf fmt
"%a(@[<hov 0>SourcePosition(filename=\"%s\",@ start_line=%d,@ \ "%a(@[<hov 0>SourcePosition(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]" 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) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos)
format_string_list (Pos.get_law_info pos) format_string_list (Pos.get_law_info pos)
(Format.pp_print_list (Format.pp_print_list
@ -381,7 +381,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(format_expression ctx)) (format_expression ctx))
args args
| EAppOp { op; 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 (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx)) (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)) (fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es es
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l) | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
| EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } -> | EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } ->
Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos) Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1 (format_expression ctx) arg2 (format_expression ctx) arg2
| EAppOp { op; args = [arg1; arg2] } -> | EAppOp { op; args = [arg1; arg2] } ->
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op
(op, Pos.no_pos) (format_expression ctx) arg2 (format_expression ctx) arg2
| EAppOp { op = Not; args = [arg1] } -> | EAppOp { op = (Not, _) as op; args = [arg1] } ->
Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos) Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1
| EAppOp | 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]; args = [arg1];
} -> } ->
Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos) Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1
| EAppOp { op; args = [arg1] } -> | EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos) Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
(format_expression ctx) arg1 | EAppOp { op = HandleDefaultOpt, _; _ } ->
| EAppOp { op = HandleDefaultOpt; _ } ->
Message.error ~internal:true Message.error ~internal:true
"R compilation does not currently support the avoiding of exceptions" "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 let pos = Mark.get e in
Format.fprintf fmt Format.fprintf fmt
"%a(@[<hov 0>catala_position(filename=\"%s\",@ start_line=%d,@ \ "%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)) (format_expression ctx))
args args
| EAppOp { op; 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 (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx)) (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 = (markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
if Global.options.trace then if Global.options.trace then
Expr.eappop Expr.eappop
~op:(Log (l, markings)) ~op:(Log (l, markings), Expr.pos e)
~tys:[TAny, Expr.pos e] ~tys:[TAny, Expr.pos e]
~args:[e] (Mark.get e) ~args:[e] (Mark.get e)
else 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) ~monomorphic:(fun op -> Expr.eappop ~op ~tys ~args m)
~polymorphic:(fun op -> Expr.eappop ~op ~tys ~args m) ~polymorphic:(fun op -> Expr.eappop ~op ~tys ~args m)
~overloaded:(fun op -> ~overloaded:(fun op ->
match match Operator.resolve_overload ctx.decl_ctx op tys with
Operator.resolve_overload ctx.decl_ctx (Mark.add (Expr.pos e) op) tys
with
| op, `Straight -> Expr.eappop ~op ~tys ~args m | op, `Straight -> Expr.eappop ~op ~tys ~args m
| op, `Reversed -> | op, `Reversed ->
Expr.eappop ~op ~tys:(List.rev tys) ~args:(List.rev args) m) 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 -> ('a, < .. >, 'm) base_gexpr
| EAppOp : { | EAppOp : {
op : 'a operator; op : 'a operator Mark.pos;
args : ('a, 'm) gexpr list; args : ('a, 'm) gexpr list;
tys : typ list; tys : typ list;
} }

11
compiler/shared_ast/expr.ml
View File

@ -300,7 +300,9 @@ let runtime_to_pos rpos =
let map let map
(type a b) (type a b)
?(typ : typ -> typ = Fun.id) ?(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) ~(f : (a, 'm1) gexpr -> (b, 'm2) boxed_gexpr)
(e : ((a, b, 'm1) base_gexpr, 'm2) marked) : (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 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 equal e1 e2 && equal_list args1 args2 && Type.equal_list tys1 tys2
| ( EAppOp { op = op1; args = args1; tys = tys1 }, | ( EAppOp { op = op1; args = args1; tys = tys1 },
EAppOp { op = op2; args = args2; tys = tys2 } ) -> EAppOp { op = op2; args = args2; tys = tys2 } ) ->
Operator.equal op1 op2 Mark.equal Operator.equal op1 op2
&& equal_list args1 args2 && equal_list args1 args2
&& Type.equal_list tys1 tys2 && Type.equal_list tys1 tys2
| EAssert e1, EAssert e2 -> equal e1 e2 | 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 compare args1 args2 @@< fun () ->
List.compare Type.compare tys1 tys2 List.compare Type.compare tys1 tys2
| EAppOp {op=op1; args=args1; tys=tys1}, EAppOp {op=op2; args=args2; tys=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 compare args1 args2 @@< fun () ->
List.compare Type.compare tys1 tys2 List.compare Type.compare tys1 tys2
| EArray a1, EArray a2 -> | EArray a1, EArray a2 ->
@ -845,7 +847,8 @@ let remove_logging_calls e =
let rec f e = let rec f e =
let e, m = map ~f ~op:Fun.id e in let e, m = map ~f ~op:Fun.id e in
( Bindlib.box_apply ( Bindlib.box_apply
(function EAppOp { op = Log _; args = [(arg, _)]; _ } -> arg | e -> e) (function
| EAppOp { op = Log _, _; args = [(arg, _)]; _ } -> arg | e -> e)
e, e,
m ) m )
in 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 efatalerror : Runtime.error -> 'm mark -> (< .. >, 'm) boxed_gexpr
val eappop : val eappop :
op:'a operator -> op:'a operator Mark.pos ->
args:('a, 'm) boxed_gexpr list -> args:('a, 'm) boxed_gexpr list ->
tys:typ list -> tys:typ list ->
'm mark -> 'm mark ->
@ -243,7 +243,7 @@ val untype : ('a, 'm) gexpr -> ('a, untyped) boxed_gexpr
val map : val map :
?typ:(typ -> typ) -> ?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) -> f:(('a, 'm1) gexpr -> ('b, 'm2) boxed_gexpr) ->
(('a, 'b, 'm1) base_gexpr, 'm2) marked -> (('a, 'b, 'm1) base_gexpr, 'm2) marked ->
('b, 'm2) boxed_gexpr ('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 (* Todo: this should be handled early when resolving overloads. Here we have
proper structural equality, but the OCaml backend for example uses the proper structural equality, but the OCaml backend for example uses the
builtin equality function instead of this. *) 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 let open Runtime.Oper in
match e1, e2 with match e1, e2 with
| ELit LUnit, ELit LUnit -> true | ELit LUnit, ELit LUnit -> true
@ -77,7 +78,7 @@ let handle_eq evaluate_operator m lang e1 e2 =
try try
List.for_all2 List.for_all2
(fun e1 e2 -> (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 | ELit (LBool b) -> b
| _ -> assert false | _ -> assert false
(* should not happen *)) (* should not happen *))
@ -87,7 +88,7 @@ let handle_eq evaluate_operator m lang e1 e2 =
StructName.equal s1 s2 StructName.equal s1 s2
&& StructField.Map.equal && StructField.Map.equal
(fun e1 e2 -> (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 | ELit (LBool b) -> b
| _ -> assert false | _ -> assert false
(* should not happen *)) (* should not happen *))
@ -98,7 +99,7 @@ let handle_eq evaluate_operator m lang e1 e2 =
EnumName.equal en1 en2 EnumName.equal en1 en2
&& EnumConstructor.equal i1 i2 && 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 | ELit (LBool b) -> b
| _ -> assert false | _ -> assert false
(* should not happen *) (* 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 *) (* Call-by-value: the arguments are expected to be already evaluated here *)
let rec evaluate_operator let rec evaluate_operator
evaluate_expr evaluate_expr
(op : < overloaded : no ; .. > operator) ((op, opos) : < overloaded : no ; .. > operator Mark.pos)
m m
lang lang
args = args =
let pos = Expr.mark_pos m in 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 () = let err () =
Message.error Message.error
~extra_pos: ~extra_pos:
@ -121,7 +122,7 @@ let rec evaluate_operator
( Format.asprintf "Operator (value %a):" ( Format.asprintf "Operator (value %a):"
(Print.operator ~debug:true) (Print.operator ~debug:true)
op, op,
pos ); opos );
] ]
@ List.mapi @ List.mapi
(fun i arg -> (fun i arg ->
@ -151,7 +152,7 @@ let rec evaluate_operator
Mark.remove e' Mark.remove e'
| (ToClosureEnv | FromClosureEnv), _ -> err () | (ToClosureEnv | FromClosureEnv), _ -> err ()
| Eq, [(e1, _); (e2, _)] -> | 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, _)] -> | Map, [f; (EArray es, _)] ->
EArray EArray
(List.map (List.map
@ -814,12 +815,13 @@ and partially_evaluate_expr_for_assertion_failure_message :
args = [e1; e2]; args = [e1; e2];
tys; tys;
op = op =
( And | Or | Xor | Eq | Lt_int_int | Lt_rat_rat | Lt_mon_mon ( ( 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 | 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 | 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 | 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 | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon
| Eq_dur_dur | Eq_dat_dat ) as op; | Eq_dur_dur | Eq_dat_dat ),
_ ) as op;
} -> } ->
( EAppOp ( 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 (Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr
~name:Expr.option_enum mark_e) ~name:Expr.option_enum mark_e)
ty_in (Expr.mark_pos 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] ~args:[Expr.etuple [] mark_e]
~tys:[TClosureEnv, pos] ~tys:[TClosureEnv, pos]
mark_e; mark_e;

2
compiler/shared_ast/interpreter.mli
View File

@ -22,7 +22,7 @@ open Definitions
val evaluate_operator : val evaluate_operator :
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) -> ((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
'a operator -> 'a operator Mark.pos ->
'm mark -> 'm mark ->
Global.backend_lang -> Global.backend_lang ->
('a, 'm) gexpr list -> ('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 : let kind_dispatch :
type a. type a.
polymorphic:(< polymorphic : yes ; .. > t -> 'b) -> polymorphic:(< polymorphic : yes ; .. > t Mark.pos -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t -> 'b) -> monomorphic:(< monomorphic : yes ; .. > t Mark.pos -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t -> 'b) -> ?overloaded:(< overloaded : yes ; .. > t Mark.pos -> 'b) ->
?resolved:(< resolved : yes ; .. > t -> 'b) -> ?resolved:(< resolved : yes ; .. > t Mark.pos -> 'b) ->
a t -> a t Mark.pos ->
'b = 'b =
fun ~polymorphic ~monomorphic ?(overloaded = fun _ -> assert false) fun ~polymorphic ~monomorphic ?(overloaded = fun _ -> assert false)
?(resolved = fun _ -> assert false) op -> ?(resolved = fun _ -> assert false) op ->
match op with match op with
| ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | And | ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| Or | Xor ) as op -> | And | Or | Xor ),
_ ) as op ->
monomorphic op monomorphic op
| ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold | ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold
| HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ) as op | HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ),
-> _ ) as op ->
polymorphic op polymorphic op
| ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt | ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt
| Gte ) as op -> | Gte ),
_ ) as op ->
overloaded op overloaded op
| ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon | ( ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon
| ToMoney_rat | Round_rat | Round_mon | Add_int_int | Add_rat_rat | 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 | 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 | 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 | 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 | 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 | 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 | 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 | 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 | 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 -> | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur ),
_ ) as op ->
resolved op resolved op
type 'a no_overloads = type 'a no_overloads =
@ -371,22 +374,23 @@ type 'a no_overloads =
as as
'a '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 match t with
| ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | And | ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq | Map | And | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq
| Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat | Minus_mon | Map | Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat
| Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat | Round_mon | Minus_mon | Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat
| Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _ | Add_dur_dur | Round_mon | Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _
| Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur | Add_dur_dur | Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat
| Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int | Sub_dat_dur | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur | Mult_dur_int | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat
| Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur | Div_dur_dur | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat
| Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat
| Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat
| Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat
| Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat
| FromClosureEnv | ToClosureEnv ) as op -> | Eq_dur_dur | FromClosureEnv | ToClosureEnv ),
_ ) as op ->
op op
let monomorphic_type ((op : monomorphic t), pos) = 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 raise Not_found
let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) : let resolve_overload
< resolved : yes ; .. > t * [ `Straight | `Reversed ] = ctx
((op, pos) : overloaded t Mark.pos)
(operands : typ list) :
< resolved : yes ; .. > t Mark.pos * [ `Straight | `Reversed ] =
try try
let operands = let operands =
List.map 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) match Mark.remove t with TLit tl -> tl | _ -> raise Not_found)
operands operands
in in
resolve_overload_aux (Mark.remove op) operands let op, direction = resolve_overload_aux op operands in
(op, pos), direction
with Not_found -> with Not_found ->
Message.error Message.error
~extra_pos: ~extra_pos:
(("", Mark.get op) (("", pos)
:: List.map :: List.map
(fun ty -> (fun ty ->
( Format.asprintf "Type %a coming from expression:" ( Format.asprintf "Type %a coming from expression:"
@ -559,7 +567,7 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
operands) operands)
"I don't know how to apply operator %a on types %a" "I don't know how to apply operator %a on types %a"
(Print.operator ~debug:true) (Print.operator ~debug:true)
(Mark.remove op) op
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf " and@ ") ~pp_sep:(fun ppf () -> Format.fprintf ppf " and@ ")
(Print.typ ctx)) (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 overload_type ctx (op : overloaded t Mark.pos) (operands : typ list) : typ =
let rop = fst (resolve_overload ctx op operands) in 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. [+$]. *) symbols, e.g. [+$]. *)
val kind_dispatch : val kind_dispatch :
polymorphic:(< polymorphic : yes ; .. > t -> 'b) -> polymorphic:(< polymorphic : yes ; .. > t Mark.pos -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t -> 'b) -> monomorphic:(< monomorphic : yes ; .. > t Mark.pos -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t -> 'b) -> ?overloaded:(< overloaded : yes ; .. > t Mark.pos -> 'b) ->
?resolved:(< resolved : yes ; .. > t -> 'b) -> ?resolved:(< resolved : yes ; .. > t Mark.pos -> 'b) ->
'a t -> 'a t Mark.pos ->
'b 'b
(** Calls one of the supplied functions depending on the kind of the operator *) (** Calls one of the supplied functions depending on the kind of the operator *)
@ -60,7 +60,7 @@ type 'a no_overloads =
as as
'a '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 (** An identity function that allows translating an operator between different
passes that don't change operator types *) passes that don't change operator types *)
@ -84,7 +84,7 @@ val resolve_overload :
decl_ctx -> decl_ctx ->
overloaded t Mark.pos -> overloaded t Mark.pos ->
typ list -> 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. (** Some overloads are sugar for an operation with reversed operands, e.g.
[TRat * TMoney] is using [mult_mon_rat]. [`Reversed] is returned to signify [TRat * TMoney] is using [mult_mon_rat]. [`Reversed] is returned to signify
this case. *) 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 the matches and the log calls are not preserved, which would be a good
property *) property *)
match Mark.remove e with match Mark.remove e with
| EAppOp { op = Not; args = [(ELit (LBool b), _)]; _ } -> | EAppOp { op = Not, _; args = [(ELit (LBool b), _)]; _ } ->
(* reduction of logical not *) (* reduction of logical not *)
ELit (LBool (not b)) ELit (LBool (not b))
| EAppOp { op = Or; args = [(ELit (LBool b), _); (e, _)]; _ } | EAppOp { op = Or, _; args = [(ELit (LBool b), _); (e, _)]; _ }
| EAppOp { op = Or; args = [(e, _); (ELit (LBool b), _)]; _ } -> | EAppOp { op = Or, _; args = [(e, _); (ELit (LBool b), _)]; _ } ->
(* reduction of logical or *) (* reduction of logical or *)
if b then ELit (LBool true) else e if b then ELit (LBool true) else e
| EAppOp { op = And; args = [(ELit (LBool b), _); (e, _)]; _ } | EAppOp { op = And, _; args = [(ELit (LBool b), _); (e, _)]; _ }
| EAppOp { op = And; args = [(e, _); (ELit (LBool b), _)]; _ } -> | EAppOp { op = And, _; args = [(e, _); (ELit (LBool b), _)]; _ } ->
(* reduction of logical and *) (* reduction of logical and *)
if b then e else ELit (LBool false) if b then e else ELit (LBool false)
| EMatch { e = EInj { e = e'; cons; name = n' }, _; cases; name = n } | 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 match Mark.remove b1, Mark.remove e2 with
| EAbs { binder = b1; _ }, EAbs { binder = b2; tys } -> ( | EAbs { binder = b1; _ }, EAbs { binder = b2; tys } -> (
let v1, e1 = Bindlib.unmbind b1 in let v1, e1 = Bindlib.unmbind b1 in
let[@warning "-8"] [| v1 |] = v1 in
match Mark.remove e1 with match Mark.remove e1 with
| EInj { e = e1; _ } -> | EInj { e = e1, _; _ } ->
Some Some
(Expr.unbox (Expr.unbox
(Expr.make_abs [| v1 |] (Expr.make_abs v1
(Expr.rebox (Expr.rebox (Bindlib.msubst b2 [| e1 |]))
(Bindlib.msubst b2
([e1] |> List.map fst |> Array.of_list)))
tys (Expr.pos e2))) tys (Expr.pos e2)))
| _ -> assert false) | _ -> assert false)
| _ -> assert false) | _ -> assert false)
@ -198,13 +195,13 @@ let rec optimize_expr :
Mark.remove cons Mark.remove cons
| ( [], | ( [],
( ( ELit (LBool false) ( ( ELit (LBool false)
| EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), | EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ),
_ ) ) -> _ ) ) ->
(* No exceptions and condition false *) (* No exceptions and condition false *)
EEmpty EEmpty
| ( [except], | ( [except],
( ( ELit (LBool false) ( ( ELit (LBool false)
| EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), | EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ),
_ ) ) -> _ ) ) ->
(* Single exception and condition false *) (* Single exception and condition false *)
Mark.remove except Mark.remove except
@ -213,7 +210,7 @@ let rec optimize_expr :
{ {
cond = cond =
( ELit (LBool true), _ ( ELit (LBool true), _
| EAppOp { op = Log _; args = [(ELit (LBool true), _)]; _ }, _ ); | EAppOp { op = Log _, _; args = [(ELit (LBool true), _)]; _ }, _ );
etrue; etrue;
_; _;
} -> } ->
@ -222,7 +219,7 @@ let rec optimize_expr :
{ {
cond = cond =
( ( ELit (LBool false) ( ( ELit (LBool false)
| EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), | EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ),
_ ); _ );
efalse; efalse;
_; _;
@ -233,32 +230,37 @@ let rec optimize_expr :
cond; cond;
etrue = etrue =
( ( ELit (LBool btrue) ( ( ELit (LBool btrue)
| EAppOp { op = Log _; args = [(ELit (LBool btrue), _)]; _ } ), | EAppOp { op = Log _, _; args = [(ELit (LBool btrue), _)]; _ } ),
_ ); _ );
efalse = efalse =
( ( ELit (LBool bfalse) ( ( 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 if btrue && not bfalse then Mark.remove cond
else if (not btrue) && bfalse then else if (not btrue) && bfalse then
EAppOp 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 (* note: this last call eliminates the condition & might skip log calls
as well *) as well *)
else (* btrue = bfalse *) ELit (LBool btrue) 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 *) (*reduces a fold with an empty list *)
Mark.remove init Mark.remove init
| EAppOp | EAppOp
{ {
op = Map; op = (Map, _) as op;
args = args =
[ [
f1; f1;
( EAppOp ( EAppOp
{ {
op = Map; op = Map, _;
args = [f2; ls]; args = [f2; ls];
tys = [_; ((TArray xty, _) as lsty)]; tys = [_; ((TArray xty, _) as lsty)];
}, },
@ -286,7 +288,7 @@ let rec optimize_expr :
in in
let fg = optimize_expr ctx (Expr.unbox fg) in let fg = optimize_expr ctx (Expr.unbox fg) in
let mapl = let mapl =
Expr.eappop ~op:Map Expr.eappop ~op
~args:[fg; Expr.box ls] ~args:[fg; Expr.box ls]
~tys:[Expr.maybe_ty (Mark.get fg); lsty] ~tys:[Expr.maybe_ty (Mark.get fg); lsty]
mark mark
@ -294,13 +296,13 @@ let rec optimize_expr :
Mark.remove (Expr.unbox mapl) Mark.remove (Expr.unbox mapl)
| EAppOp | EAppOp
{ {
op = Map; op = Map, _;
args = args =
[ [
f1; f1;
( EAppOp ( EAppOp
{ {
op = Map2; op = (Map2, _) as op;
args = [f2; ls1; ls2]; args = [f2; ls1; ls2];
tys = tys =
[ [
@ -339,7 +341,7 @@ let rec optimize_expr :
in in
let fg = optimize_expr ctx (Expr.unbox fg) in let fg = optimize_expr ctx (Expr.unbox fg) in
let mapl = let mapl =
Expr.eappop ~op:Map2 Expr.eappop ~op
~args:[fg; Expr.box ls1; Expr.box ls2] ~args:[fg; Expr.box ls1; Expr.box ls2]
~tys:[Expr.maybe_ty (Mark.get fg); ls1ty; ls2ty] ~tys:[Expr.maybe_ty (Mark.get fg); ls1ty; ls2ty]
mark mark
@ -347,7 +349,7 @@ let rec optimize_expr :
Mark.remove (Expr.unbox mapl) Mark.remove (Expr.unbox mapl)
| EAppOp | EAppOp
{ {
op = Op.Fold; op = Op.Fold, _;
args = [f; init; (EArray [e'], _)]; args = [f; init; (EArray [e'], _)];
tys = [_; tinit; (TArray tx, _)]; tys = [_; tinit; (TArray tx, _)];
} -> } ->

20
compiler/shared_ast/print.ml
View File

@ -370,7 +370,7 @@ module Precedence = struct
match Mark.remove e with match Mark.remove e with
| ELit _ -> Contained (* Todo: unop if < 0 *) | ELit _ -> Contained (* Todo: unop if < 0 *)
| EAppOp { op; _ } -> ( | EAppOp { op; _ } -> (
match op with match Mark.remove op with
| Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| Length | Log _ | Minus | Minus_int | Minus_rat | Minus_mon | Minus_dur | Length | Log _ | Minus | Minus_int | Minus_rat | Minus_mon | Minus_dur
| ToRat | ToRat_int | ToRat_mon | ToMoney | ToMoney_rat | Round | ToRat | ToRat_int | ToRat_mon | ToMoney | ToMoney_rat | Round
@ -571,16 +571,16 @@ module ExprGen (C : EXPR_PARAM) = struct
Format.pp_close_box fmt (); Format.pp_close_box fmt ();
punctuation fmt ")")) punctuation fmt ")"))
xs_tau punctuation "→" (rhs expr) body 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 Format.fprintf fmt "@[<hv 2>%a %a@ %a@]" operator op (lhs exprc) arg1
(rhs exprc) arg2 (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 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 prec = Precedence.expr e in
let rec pr colors fmt = function let rec pr colors fmt = function
(* Flatten sequences of the same associative op *) (* 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 (match prec with
| Op (And | Or | Mul | Add | Div | Sub) -> lhs pr fmt arg1 | Op (And | Or | Mul | Add | Div | Sub) -> lhs pr fmt arg1
| _ -> lhs exprc fmt arg1); | _ -> lhs exprc fmt arg1);
@ -595,9 +595,9 @@ module ExprGen (C : EXPR_PARAM) = struct
Format.pp_open_hvbox fmt 0; Format.pp_open_hvbox fmt 0;
pr colors fmt e; pr colors fmt e;
Format.pp_close_box fmt () 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 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.fprintf fmt "@[<hv 2>%a@ %a@]" operator op
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
@ -761,7 +761,7 @@ module ExprConciseParam = struct
let lit = lit let lit = lit
let rec pre_map : type a. (a, 't) gexpr -> (a, 't) gexpr = function 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 | e -> e
end 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 (* This function is re-exported from module [Expr], but defined here where it's
first needed *) first needed *)
let rec skip_wrappers : type a. (a, 'm) gexpr -> (a, 'm) gexpr = function let rec skip_wrappers : type a. (a, 'm) gexpr -> (a, 'm) gexpr = function
| EAppOp { op = Log _; args = [e]; tys = _ }, _ -> skip_wrappers e | EAppOp { op = Log _, _; args = [e]; tys = _ }, _ -> skip_wrappers e
| EApp { f = EAppOp { op = Log _; args = [f]; _ }, _; args; tys }, m -> | EApp { f = EAppOp { op = Log _, _; args = [f]; _ }, _; args; tys }, m ->
skip_wrappers (EApp { f; args; tys }, m) skip_wrappers (EApp { f; args; tys }, m)
| EErrorOnEmpty e, _ -> skip_wrappers e | EErrorOnEmpty e, _ -> skip_wrappers e
| EDefault { excepts = []; just = ELit (LBool true), _; cons = 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 let resolve_overload_ret_type
~flags ~flags
(ctx : A.decl_ctx) (ctx : A.decl_ctx)
e _e
(op : Operator.overloaded A.operator) (op : Operator.overloaded A.operator Mark.pos)
tys : unionfind_typ = tys : unionfind_typ =
let op_ty = let op_ty =
Operator.overload_type ctx Operator.overload_type ctx op (List.map (typ_to_ast ~flags) tys)
(Mark.add (Expr.pos e) op)
(List.map (typ_to_ast ~flags) tys)
in in
ast_to_typ (Type.arrow_return op_ty) 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_args = List.map ast_to_typ tys in
let t_func = unionfind (TArrow (t_args, tau)) in let t_func = unionfind (TArrow (t_args, tau)) in
let args = let args =
Operator.kind_dispatch op Operator.kind_dispatch (Mark.set pos_e op)
~polymorphic:(fun op -> ~polymorphic:(fun op ->
(* Type the operator first, then right-to-left: polymorphic operators (* Type the operator first, then right-to-left: polymorphic operators
are required to allow the resolution of all type variables this are required to allow the resolution of all type variables this
way *) way *)
if not env.flags.assume_op_types then if not env.flags.assume_op_types then
unify ctx e (polymorphic_op_type (Mark.add pos_e op)) t_func unify ctx e (polymorphic_op_type op) t_func
else else unify ctx e (polymorphic_op_return_type ctx e op t_args) tau;
unify ctx e
(polymorphic_op_return_type ctx e (Mark.add pos_e op) t_args)
tau;
List.rev_map2 List.rev_map2
(typecheck_expr_top_down ctx env) (typecheck_expr_top_down ctx env)
(List.rev t_args) (List.rev args)) (List.rev t_args) (List.rev args))
@ -908,15 +903,11 @@ and typecheck_expr_top_down :
args') args')
~monomorphic:(fun op -> ~monomorphic:(fun op ->
(* Here it doesn't matter but may affect the error messages *) (* Here it doesn't matter but may affect the error messages *)
unify ctx e unify ctx e (ast_to_typ (Operator.monomorphic_type op)) t_func;
(ast_to_typ (Operator.monomorphic_type (Mark.add pos_e op)))
t_func;
List.map2 (typecheck_expr_top_down ctx env) t_args args) List.map2 (typecheck_expr_top_down ctx env) t_args args)
~resolved:(fun op -> ~resolved:(fun op ->
(* This case should not fail *) (* This case should not fail *)
unify ctx e unify ctx e (ast_to_typ (Operator.resolved_type op)) t_func;
(ast_to_typ (Operator.resolved_type (Mark.add pos_e op)))
t_func;
List.map2 (typecheck_expr_top_down ctx env) t_args args) List.map2 (typecheck_expr_top_down ctx env) t_args args)
in in
(* All operator applications are monomorphised at this point *) (* 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 | LDate of literal_date
and collection_op = and collection_op =
| Member of { element : expression }
| Exists of { predicate : lident Mark.pos list * expression } | Exists of { predicate : lident Mark.pos list * expression }
| Forall of { predicate : lident Mark.pos list * expression } | Forall of { predicate : lident Mark.pos list * expression }
| Map of { f : 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 | IfThenElse of expression * expression * expression
| Binop of binop Mark.pos * expression * expression | Binop of binop Mark.pos * expression * expression
| Unop of unop Mark.pos * expression | Unop of unop Mark.pos * expression
| CollectionOp of collection_op * expression | CollectionOp of collection_op Mark.pos * expression
| MemCollection of expression * expression
| TestMatchCase of expression * match_case_pattern Mark.pos | TestMatchCase of expression * match_case_pattern Mark.pos
| FunCall of expression * expression list | FunCall of expression * expression list
| ScopeCall of | ScopeCall of

43
compiler/surface/parser.mly
View File

@ -232,25 +232,26 @@ let naked_expression ==
RBRACE ; { RBRACE ; {
StructReplace (e, fields) StructReplace (e, fields)
} }
| e1 = expression ; | coll = expression ;
CONTAINS ; pos = pos(CONTAINS) ;
e2 = expression ; { element = expression ; {
MemCollection (e2, e1) CollectionOp ((Member { element }, pos), coll)
} %prec apply } %prec apply
| SUM ; typ = addpos(primitive_typ) ; | pos = pos(SUM) ; typ = addpos(primitive_typ) ;
OF ; coll = expression ; { OF ; coll = expression ; {
CollectionOp (AggregateSum { typ = Mark.remove typ }, coll) CollectionOp ((AggregateSum { typ = Mark.remove typ }, pos), coll)
} %prec apply } %prec apply
| f = expression ; | f = expression ;
FOR ; i = mbinder ; pos = pos(FOR) ; i = mbinder ;
AMONG ; coll = expression ; { AMONG ; coll = expression ; {
CollectionOp (Map {f = i, f}, coll) CollectionOp ((Map {f = i, f}, pos), coll)
} %prec apply } %prec apply
| max = minmax ; | maxp = addpos(minmax) ;
OF ; coll = expression ; OF ; coll = expression ;
OR ; IF ; LIST_EMPTY ; THEN ; OR ; IF ; LIST_EMPTY ; THEN ;
default = expression ; { default = expression ; {
CollectionOp (AggregateExtremum { max; default }, coll) let max, pos = maxp in
CollectionOp ((AggregateExtremum { max; default }, pos), coll)
} %prec apply } %prec apply
| op = addpos(unop) ; e = expression ; { | op = addpos(unop) ; e = expression ; {
Unop (op, e) Unop (op, e)
@ -260,15 +261,15 @@ let naked_expression ==
e2 = expression ; { e2 = expression ; {
Binop (binop, e1, e2) Binop (binop, e1, e2)
} }
| EXISTS ; i = mbinder ; | pos = pos(EXISTS) ; i = mbinder ;
AMONG ; coll = expression ; AMONG ; coll = expression ;
SUCH ; THAT ; predicate = expression ; { SUCH ; THAT ; predicate = expression ; {
CollectionOp (Exists {predicate = i, predicate}, coll) CollectionOp ((Exists {predicate = i, predicate}, pos), coll)
} %prec let_expr } %prec let_expr
| FOR ; ALL ; i = mbinder ; | pos = pos(FOR) ; ALL ; i = mbinder ;
AMONG ; coll = expression ; AMONG ; coll = expression ;
WE_HAVE ; predicate = expression ; { WE_HAVE ; predicate = expression ; {
CollectionOp (Forall {predicate = i, predicate}, coll) CollectionOp ((Forall {predicate = i, predicate}, pos), coll)
} %prec let_expr } %prec let_expr
| MATCH ; e = expression ; | MATCH ; e = expression ;
WITH ; WITH ;
@ -285,23 +286,23 @@ let naked_expression ==
IN ; e2 = expression ; { IN ; e2 = expression ; {
LetIn (ids, e1, e2) LetIn (ids, e1, e2)
} %prec let_expr } %prec let_expr
| LIST; ids = mbinder ; | pos = pos(LIST); ids = mbinder ;
AMONG ; coll = expression ; AMONG ; coll = expression ;
SUCH ; THAT ; f = expression ; { SUCH ; THAT ; f = expression ; {
CollectionOp (Filter {f = ids, f}, coll) CollectionOp ((Filter {f = ids, f}, pos), coll)
} %prec top_expr } %prec top_expr
| fmap = expression ; | fmap = expression ;
FOR ; i = mbinder ; pfor = pos(FOR) ; i = mbinder ;
AMONG ; coll = expression ; AMONG ; coll = expression ;
SUCH ; THAT ; ffilt = expression ; { psuch = pos(SUCH) ; THAT ; ffilt = expression ; {
CollectionOp (Map {f = i, fmap}, (CollectionOp (Filter {f = i, ffilt}, coll), Pos.from_lpos $loc)) CollectionOp ((Map {f = i, fmap}, pfor), (CollectionOp ((Filter {f = i, ffilt}, psuch), coll), Pos.from_lpos $loc))
} %prec top_expr } %prec top_expr
| CONTENT; OF; ids = mbinder ; | pos = pos(CONTENT); OF; ids = mbinder ;
AMONG ; coll = expression ; AMONG ; coll = expression ;
SUCH ; THAT ; f = expression ; SUCH ; THAT ; f = expression ;
IS ; max = minmax ; IS ; max = minmax ;
OR ; IF ; LIST_EMPTY ; THEN ; default = expression ; { 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 } %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 -> | hd :: tl ->
( EAppOp ( EAppOp
{ {
op = And; op = And, Expr.mark_pos mark;
tys = [TLit TBool, Expr.pos hd; TLit TBool, Expr.pos hd]; tys = [TLit TBool, Expr.pos hd; TLit TBool, Expr.pos hd];
args = [hd; conjunction_exprs tl mark]; args = [hd; conjunction_exprs tl mark];
}, },
@ -54,7 +54,7 @@ let conjunction (args : vc_return list) (mark : typed mark) : vc_return =
(fun acc arg -> (fun acc arg ->
( EAppOp ( EAppOp
{ {
op = And; op = And, Expr.mark_pos mark;
tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg]; tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg];
args = [arg; acc]; args = [arg; acc];
}, },
@ -62,7 +62,13 @@ let conjunction (args : vc_return list) (mark : typed mark) : vc_return =
acc list acc list
let negation (arg : vc_return) (mark : typed mark) : vc_return = 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 disjunction (args : vc_return list) (mark : typed mark) : vc_return =
let acc, list = let acc, list =
@ -72,7 +78,7 @@ let disjunction (args : vc_return list) (mark : typed mark) : vc_return =
(fun (acc : vc_return) arg -> (fun (acc : vc_return) arg ->
( EAppOp ( EAppOp
{ {
op = Or; op = Or, Expr.mark_pos mark;
tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg]; tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg];
args = [arg; acc]; 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 (** [translate_op] returns the Z3 expression corresponding to the application of
[op] to the arguments [args] **) [op] to the arguments [args] **)
let rec translate_op : let rec translate_op :
context -> dcalc operator -> 'm expr list -> context * Expr.expr = context -> dcalc operator Mark.pos -> 'm expr list -> context * Expr.expr =
fun ctx op args -> fun ctx (op, pos) args ->
let ill_formed () = let ill_formed () =
Format.kasprintf failwith Format.kasprintf failwith
"[Z3 encoding] Ill-formed operator application: %a" Shared_ast.Expr.format "[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) ~args:(List.map Shared_ast.Expr.untype args)
~tys:[] ~tys:[]
(Untyped { pos = Pos.no_pos }) (Untyped { pos })
|> Shared_ast.Expr.unbox) |> Shared_ast.Expr.unbox)
in in
let app f = let app f =
@ -458,7 +458,7 @@ let rec translate_op :
failwith "[Z3 encoding] ternary operator application not supported" failwith "[Z3 encoding] ternary operator application not supported"
(* Special case for GetYear comparisons *) (* Special case for GetYear comparisons *)
| ( Lt_int_int, | ( 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 n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in let ctx, e1 = translate_expr ctx e1 in
let e2 = let e2 =
@ -469,7 +469,7 @@ let rec translate_op :
days *) days *)
ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2 ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2
| ( Lte_int_int, | ( 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 ctx, e1 = translate_expr ctx e1 in
let nb_days = if is_leap_year n then 365 else 364 in let nb_days = if is_leap_year n then 365 else 364 in
let n = Runtime.integer_to_int n in let n = Runtime.integer_to_int n in
@ -483,7 +483,7 @@ let rec translate_op :
in in
ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2 ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2
| ( Gt_int_int, | ( 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 ctx, e1 = translate_expr ctx e1 in
let nb_days = if is_leap_year n then 365 else 364 in let nb_days = if is_leap_year n then 365 else 364 in
let n = Runtime.integer_to_int n in let n = Runtime.integer_to_int n in
@ -497,7 +497,7 @@ let rec translate_op :
in in
ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2 ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2
| ( Gte_int_int, | ( 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 n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in let ctx, e1 = translate_expr ctx e1 in
let e2 = let e2 =
@ -507,7 +507,7 @@ let rec translate_op :
be directly translated as >= in the Z3 encoding using the number of be directly translated as >= in the Z3 encoding using the number of
days *) days *)
ctx, Arithmetic.mk_ge ctx.ctx_z3 e1 e2 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 n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in let ctx, e1 = translate_expr ctx e1 in
let min_date = let min_date =

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

@ -32,54 +32,39 @@ scope Money:
```catala-test-inline ```catala-test-inline
$ catala Interpret -s Dec $ catala test-scope Dec
[ERROR] Error during evaluation: division by zero. [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. 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 └┬ `Division_by_zero` exception management
└─ with decimals └─ with decimals
#return code 123# #return code 123#
``` ```
```catala-test-inline ```catala-test-inline
$ catala interpret -s Int $ catala test-scope Int
[ERROR] Error during evaluation: division by zero. [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 10 │ definition i equals 1 / 0
│ ‾‾‾‾‾ │ ‾
└┬ `Division_by_zero` exception management └┬ `Division_by_zero` exception management
└─ with integers └─ with integers
#return code 123# #return code 123#
``` ```
```catala-test-inline ```catala-test-inline
$ catala Interpret -s Money $ catala test-scope Money
[ERROR] Error during evaluation: division by zero. [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 30 │ definition i equals $10.0 / $0.0
│ ‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾
└┬ `Division_by_zero` exception management └┬ `Division_by_zero` exception management
└─ with money └─ with money
#return code 123# #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. [ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days). 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 40 │ definition d equals 1 month >= 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `>=` operator └─ `>=` operator
#return code 123# #return code 123#
@ -63,10 +63,10 @@ $ catala interpret -s Gt
[ERROR] Error during evaluation: comparing durations in different units (e.g. [ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days). 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 30 │ definition d equals 1 month > 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `<=` operator └─ `<=` operator
#return code 123# #return code 123#
@ -77,10 +77,10 @@ $ catala interpret -s Le
[ERROR] Error during evaluation: comparing durations in different units (e.g. [ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days). 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 20 │ definition d equals 1 month <= 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `<=` operator └─ `<=` operator
#return code 123# #return code 123#
@ -91,10 +91,10 @@ $ catala interpret -s Lt
[ERROR] Error during evaluation: comparing durations in different units (e.g. [ERROR] Error during evaluation: comparing durations in different units (e.g.
months vs. days). 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 10 │ definition d equals 1 month < 2 day
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `<` operator └─ `<` operator
#return code 123# #return code 123#

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

@ -66,7 +66,7 @@ let half_ : integer -> decimal =
fun (x_: integer) -> fun (x_: integer) ->
o_div_int_int o_div_int_int
{filename="tests/modules/good/mod_def.catala_en"; {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 law_headings=["Test modules + inclusions 1"]} x_ (integer_of_string
"2") "2")