From cee8e57d02a378b07909f5ad6ab7b649df2955c8 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 30 Apr 2024 16:35:08 +0200 Subject: [PATCH] More precise positions for operators throughout --- compiler/dcalc/from_scopelang.ml | 7 +- compiler/desugared/from_surface.ml | 81 ++++++++-------- compiler/lcalc/closure_conversion.ml | 10 +- compiler/lcalc/compile_with_exceptions.ml | 3 +- compiler/lcalc/compile_without_exceptions.ml | 3 +- compiler/lcalc/to_ocaml.ml | 16 ++-- compiler/plugins/explain.ml | 67 ++++++++----- compiler/scalc/ast.ml | 2 +- compiler/scalc/from_lcalc.ml | 4 +- compiler/scalc/print.ml | 10 +- compiler/scalc/to_c.ml | 27 +++--- compiler/scalc/to_python.ml | 44 ++++----- compiler/scalc/to_r.ml | 29 +++--- compiler/scopelang/from_desugared.ml | 6 +- compiler/shared_ast/definitions.ml | 2 +- compiler/shared_ast/expr.ml | 11 ++- compiler/shared_ast/expr.mli | 4 +- compiler/shared_ast/interpreter.ml | 33 ++++--- compiler/shared_ast/interpreter.mli | 2 +- compiler/shared_ast/operator.ml | 96 ++++++++++--------- compiler/shared_ast/operator.mli | 14 +-- compiler/shared_ast/optimizations.ml | 54 ++++++----- compiler/shared_ast/print.ml | 20 ++-- compiler/shared_ast/typing.ml | 25 ++--- compiler/surface/ast.ml | 4 +- compiler/surface/parser.mly | 43 +++++---- compiler/verification/conditions.ml | 14 ++- compiler/verification/z3backend.real.ml | 18 ++-- .../arithmetic/bad/division_by_zero.catala_en | 33 ++----- .../date/bad/uncomparable_duration.catala_en | 16 ++-- tests/modules/good/output/mod_def.ml | 2 +- 31 files changed, 362 insertions(+), 338 deletions(-) diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index 6007c506..3f7ce22b 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -139,7 +139,8 @@ let tag_with_log_entry let m = mark_tany (Mark.get e) (Expr.pos e) in if Global.options.trace then - Expr.eappop ~op:(Log (l, markings)) ~tys:[TAny, Expr.pos e] ~args:[e] m + let pos = Expr.pos e in + Expr.eappop ~op:(Log (l, markings), pos) ~tys:[TAny, pos] ~args:[e] m else e (* In a list of exceptions, it is normally an error if more than a single one @@ -565,9 +566,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed = let v, _ = TopdefName.Map.find (Mark.remove name) ctx.toplevel_vars in Expr.evar v m else Expr.eexternal ~name:(Mark.map (fun n -> External_value n) name) m - | EAppOp { op = Add_dat_dur _; args; tys } -> + | EAppOp { op = Add_dat_dur _, opos; args; tys } -> let args = List.map (translate_expr ctx) args in - Expr.eappop ~op:(Add_dat_dur ctx.date_rounding) ~args ~tys m + Expr.eappop ~op:(Add_dat_dur ctx.date_rounding, opos) ~args ~tys m | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EFatalError _ | EEmpty | EErrorOnEmpty _ | EArray _ | EIfThenElse _ | EAppOp _ ) as e -> diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 069a2667..fef2d146 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -42,7 +42,7 @@ let translate_binop : Ast.expr boxed = fun (op, op_pos) pos lhs rhs -> let op_expr op tys = - Expr.eappop ~op + Expr.eappop ~op:(op, op_pos) ~tys:(List.map (Mark.add op_pos) tys) ~args:[lhs; rhs] (Untyped { pos }) @@ -114,7 +114,10 @@ let translate_binop : let translate_unop ((op, op_pos) : S.unop Mark.pos) pos arg : Ast.expr boxed = let op_expr op ty = - Expr.eappop ~op ~tys:[Mark.add op_pos ty] ~args:[arg] (Untyped { pos }) + Expr.eappop ~op:(op, op_pos) + ~tys:[Mark.add op_pos ty] + ~args:[arg] + (Untyped { pos }) in match op with | S.Not -> op_expr Not (TLit TBool) @@ -238,12 +241,12 @@ let rec translate_expr let rec_helper ?(local_vars = local_vars) e = translate_expr scope inside_definition_of ctxt local_vars e in - let rec detuplify_list names = function + let rec detuplify_list opos names = function (* Where a list is expected (e.g. after [among]), as syntactic sugar, if a tuple is found instead we transpose it into a list of tuples *) | S.Tuple ls, pos -> let m = Untyped { pos } in - let ls = List.map (detuplify_list []) ls in + let ls = List.map (detuplify_list opos []) ls in let rec zip names = function | [] -> assert false | [l] -> l @@ -272,7 +275,7 @@ let rec translate_expr (Expr.make_tuple (Expr.evar x1 m :: explode (Expr.evar x2 m)) m) tys pos in - Expr.eappop ~op:Map2 ~args:[f_join; l1; rhs] + Expr.eappop ~op:(Map2, opos) ~args:[f_join; l1; rhs] ~tys:((TAny, pos) :: List.map (fun ty -> TArray ty, pos) tys) m in @@ -286,7 +289,7 @@ let rec translate_expr match Mark.remove expr with | Paren e -> rec_helper e | Binop - ( (S.And, _pos_op), + ( (S.And, pos_op), ( TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)), _pos_e1 ), e2 ) -> @@ -302,14 +305,14 @@ let rec translate_expr let nop_var = Var.make "_" in Expr.make_abs [| nop_var |] (Expr.elit (LBool false) emark) - [tau] pos + [tau] pos_op else let binding_var = Var.make (Mark.remove binding) in let local_vars = Ident.Map.add (Mark.remove binding) binding_var local_vars in let e2 = rec_helper ~local_vars e2 in - Expr.make_abs [| binding_var |] e2 [tau] pos) + Expr.make_abs [| binding_var |] e2 [tau] pos_op) (EnumName.Map.find enum_uid ctxt.enums) in Expr.ematch ~e:(rec_helper e1_sub) ~name:enum_uid ~cases emark @@ -493,7 +496,7 @@ let rec translate_expr in Expr.edstructaccess ~e ~field:(Mark.remove x) ~name_opt:(get_str ctxt path) emark - | FunCall ((Builtin b, _), [arg]) -> + | FunCall ((Builtin b, pos), [arg]) -> let op, ty = match b with | S.ToDecimal -> Op.ToRat, TAny @@ -506,7 +509,7 @@ let rec translate_expr | S.FirstDayOfMonth -> Op.FirstDayOfMonth, TLit TDate | S.LastDayOfMonth -> Op.LastDayOfMonth, TLit TDate in - Expr.eappop ~op ~tys:[ty, pos] ~args:[rec_helper arg] emark + Expr.eappop ~op:(op, pos) ~tys:[ty, pos] ~args:[rec_helper arg] emark | S.Builtin _ -> Message.error ~pos "Invalid use of built-in: needs one operand" | FunCall (f, args) -> @@ -723,10 +726,10 @@ let rec translate_expr | Tuple es -> Expr.etuple (List.map rec_helper es) emark | TupleAccess (e, n) -> Expr.etupleaccess ~e:(rec_helper e) ~index:(Mark.remove n - 1) ~size:0 emark - | CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) -> + | CollectionOp ((((S.Filter { f } | S.Map { f }), opos) as op), collection) -> let param_names, predicate = f in let collection = - detuplify_list (List.map Mark.remove param_names) collection + detuplify_list opos (List.map Mark.remove param_names) collection in let params = List.map (fun n -> Var.make (Mark.remove n)) param_names in let local_vars = @@ -762,18 +765,19 @@ let rec translate_expr Expr.eappop ~op: (match op with - | S.Map _ -> Map - | S.Filter _ -> Filter + | S.Map _, pos -> Map, pos + | S.Filter _, pos -> Filter, pos | _ -> assert false) ~tys:[TAny, pos; TAny, pos] ~args:[f_pred; collection] emark | CollectionOp - ( S.AggregateArgExtremum { max; default; f = param_names, predicate }, + ( ( S.AggregateArgExtremum { max; default; f = param_names, predicate }, + opos ), collection ) -> let default = rec_helper default in let pos_dft = Expr.pos default in let collection = - detuplify_list (List.map Mark.remove param_names) collection + detuplify_list opos (List.map Mark.remove param_names) collection in let params = List.map (fun n -> Var.make (Mark.remove n)) param_names in let local_vars = @@ -781,7 +785,7 @@ let rec translate_expr (fun vars n p -> Ident.Map.add (Mark.remove n) p vars) local_vars param_names params in - let cmp_op = if max then Op.Gt else Op.Lt in + let cmp_op = if max then Op.Gt, opos else Op.Lt, opos in let f_pred = Expr.make_abs (Array.of_list params) (rec_helper ~local_vars predicate) @@ -820,10 +824,10 @@ let rec translate_expr let weighted_result = Expr.make_let_in weights_var (TArray (TTuple [TAny, pos; TAny, pos], pos), pos) - (Expr.eappop ~op:Map + (Expr.eappop ~op:(Map, opos) ~tys:[TAny, pos; TArray (TAny, pos), pos] ~args:[add_weight_f; collection] emark) - (Expr.eappop ~op:Reduce + (Expr.eappop ~op:(Reduce, opos) ~tys:[TAny, pos; TAny, pos; TAny, pos] ~args:[reduce_f; default; Expr.evar weights_var emark] emark) @@ -831,14 +835,15 @@ let rec translate_expr in Expr.etupleaccess ~e:weighted_result ~index:0 ~size:2 emark | CollectionOp - (((Exists { predicate } | Forall { predicate }) as op), collection) -> + ((((Exists { predicate } | Forall { predicate }), opos) as op), collection) + -> let collection = - detuplify_list (List.map Mark.remove (fst predicate)) collection + detuplify_list opos (List.map Mark.remove (fst predicate)) collection in let init, op = match op with - | Exists _ -> false, S.Or - | Forall _ -> true, S.And + | Exists _, pos -> false, (S.Or, pos) + | Forall _, pos -> true, (S.And, pos) | _ -> assert false in let init = Expr.elit (LBool init) emark in @@ -857,15 +862,14 @@ let rec translate_expr Expr.eabs (Expr.bind (Array.of_list (acc_var :: params)) - (translate_binop (op, pos) pos acc - (rec_helper ~local_vars predicate))) + (translate_binop op pos acc (rec_helper ~local_vars predicate))) [TAny, pos; TAny, pos] emark in - Expr.eappop ~op:Fold + Expr.eappop ~op:(Fold, opos) ~tys:[TAny, pos; TAny, pos; TAny, pos] ~args:[f; init; collection] emark - | CollectionOp (AggregateExtremum { max; default }, collection) -> + | CollectionOp ((AggregateExtremum { max; default }, opos), collection) -> let collection = rec_helper collection in let default = rec_helper default in let op = if max then S.Gt KPoly else S.Lt KPoly in @@ -880,11 +884,11 @@ let rec translate_expr [TAny, pos; TAny, pos] pos in - Expr.eappop ~op:Reduce + Expr.eappop ~op:(Reduce, opos) ~tys:[TAny, pos; TAny, pos; TAny, pos] ~args:[op_f; default; collection] emark - | CollectionOp (AggregateSum { typ }, collection) -> + | CollectionOp ((AggregateSum { typ }, opos), collection) -> let collection = rec_helper collection in let default_lit = let i0 = Runtime.integer_of_int 0 in @@ -894,7 +898,8 @@ let rec translate_expr | S.Money -> LMoney (Runtime.money_of_cents_integer i0) | S.Duration -> LDuration (Runtime.duration_of_numbers 0 0 0) | t -> - Message.error ~pos "It is impossible to sum values of type %a together" + Message.error ~pos:opos + "It is impossible to sum values of type %a together" SurfacePrint.format_primitive_typ t in let op_f = @@ -905,28 +910,28 @@ let rec translate_expr let x1 = Expr.make_var v1 emark in let x2 = Expr.make_var v2 emark in Expr.make_abs [| v1; v2 |] - (translate_binop (S.Add KPoly, pos) pos x1 x2) + (translate_binop (S.Add KPoly, opos) pos x1 x2) [TAny, pos; TAny, pos] pos in - Expr.eappop ~op:Reduce + Expr.eappop ~op:(Reduce, opos) ~tys:[TAny, pos; TAny, pos; TAny, pos] ~args:[op_f; Expr.elit default_lit emark; collection] emark - | MemCollection (member, collection) -> + | CollectionOp ((Member { element = member }, opos), collection) -> let param_var = Var.make "collection_member" in let param = Expr.make_var param_var emark in - let collection = detuplify_list ["collection_member"] collection in + let collection = detuplify_list opos ["collection_member"] collection in let init = Expr.elit (LBool false) emark in let acc_var = Var.make "acc" in let acc = Expr.make_var acc_var emark in let f_body = let member = rec_helper member in - Expr.eappop ~op:Or + Expr.eappop ~op:(Or, opos) ~tys:[TLit TBool, pos; TLit TBool, pos] ~args: [ - Expr.eappop ~op:Eq + Expr.eappop ~op:(Eq, opos) ~tys:[TAny, pos; TAny, pos] ~args:[member; param] emark; acc; @@ -939,7 +944,7 @@ let rec translate_expr [TLit TBool, pos; TAny, pos] emark in - Expr.eappop ~op:Fold + Expr.eappop ~op:(Fold, opos) ~tys:[TAny, pos; TAny, pos; TAny, pos] ~args:[f; init; collection] emark @@ -1090,7 +1095,7 @@ let merge_conditions (default_pos : Pos.t) : Ast.expr boxed = match precond, cond with | Some precond, Some cond -> - Expr.eappop ~op:And + Expr.eappop ~op:(And, default_pos) ~tys:[TLit TBool, default_pos; TLit TBool, default_pos] ~args:[precond; cond] (Mark.get cond) | Some precond, None -> Mark.remove precond, Untyped { pos = default_pos } diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index 2962654a..2e8ba1c5 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -145,7 +145,8 @@ let rec transform_closures_expr : (* let env = from_closure_env env in let arg0 = env.0 in ... *) let new_closure_body = Expr.make_let_in closure_env_var any_ty - (Expr.eappop ~op:Operator.FromClosureEnv + (Expr.eappop + ~op:(Operator.FromClosureEnv, binder_pos) ~tys:[TClosureEnv, binder_pos] ~args:[Expr.evar closure_env_arg_var binder_mark] binder_mark) @@ -178,7 +179,8 @@ let rec transform_closures_expr : (Expr.make_tuple ((Bindlib.box_var code_var, binder_mark) :: [ - Expr.eappop ~op:Operator.ToClosureEnv + Expr.eappop + ~op:(Operator.ToClosureEnv, binder_pos) ~tys:[TAny, Expr.pos e] ~args: [ @@ -197,7 +199,7 @@ let rec transform_closures_expr : (Expr.pos e) ) | EAppOp { - op = (HandleDefaultOpt | Fold | Map | Filter | Reduce) as op; + op = ((HandleDefaultOpt | Fold | Map | Filter | Reduce), _) as op; tys; args; } -> @@ -492,7 +494,7 @@ let rec hoist_closures_expr : ~args:new_args ~tys m ) | EAppOp { - op = (HandleDefaultOpt | Fold | Map | Filter | Reduce) as op; + op = ((HandleDefaultOpt | Fold | Map | Filter | Reduce), _) as op; tys; args; } -> diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml index b23d6644..d3450c13 100644 --- a/compiler/lcalc/compile_with_exceptions.ml +++ b/compiler/lcalc/compile_with_exceptions.ml @@ -51,7 +51,8 @@ let rec translate_default let exceptions = List.map (fun except -> Expr.thunk_term (translate_expr except)) exceptions in - Expr.eappop ~op:Op.HandleDefault + Expr.eappop + ~op:(Op.HandleDefault, Expr.pos cons) ~tys: [ TArray (TArrow ([TLit TUnit, pos], (TAny, pos)), pos), pos; diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 8305b35b..3f23af4a 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -61,7 +61,8 @@ let rec translate_default let pos = Expr.mark_pos mark_default in let exceptions = List.map translate_expr exceptions in let exceptions_and_cons_ty = Expr.maybe_ty mark_default in - Expr.eappop ~op:Op.HandleDefaultOpt + Expr.eappop + ~op:(Op.HandleDefaultOpt, Expr.pos cons) ~tys: [ TArray exceptions_and_cons_ty, pos; diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 5291857f..796d9fa1 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -374,14 +374,14 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : xs_tau format_expr body | EApp { - f = EAppOp { op = Log (BeginCall, info); args = [f]; _ }, _; + f = EAppOp { op = Log (BeginCall, info), _; args = [f]; _ }, _; args = [arg]; _; } when Global.options.trace -> Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info format_with_parens f format_with_parens arg - | EAppOp { op = Log (VarDef var_def_info, info); args = [arg1]; _ } + | EAppOp { op = Log (VarDef var_def_info, info), _; args = [arg1]; _ } when Global.options.trace -> Format.fprintf fmt "(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)" @@ -393,7 +393,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : var_def_info.log_io_output typ_embedding_name (var_def_info.log_typ, Pos.no_pos) format_with_parens arg1 - | EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1]; _ } + | EAppOp { op = Log (PosRecordIfTrueBool, _), _; args = [arg1]; _ } when Global.options.trace -> let pos = Expr.pos e in Format.fprintf fmt @@ -402,15 +402,15 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) format_with_parens arg1 - | EAppOp { op = Log (EndCall, info); args = [arg1]; _ } + | EAppOp { op = Log (EndCall, info), _; args = [arg1]; _ } when Global.options.trace -> Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info format_with_parens arg1 - | EAppOp { op = Log _; args = [arg1]; _ } -> + | EAppOp { op = Log _, _; args = [arg1]; _ } -> Format.fprintf fmt "%a" format_with_parens arg1 | EAppOp { - op = (HandleDefault | HandleDefaultOpt) as op; + op = ((HandleDefault | HandleDefaultOpt) as op), _; args = (EArray excs, _) :: _ as args; _; } -> @@ -433,14 +433,14 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : Format.fprintf fmt "@[ if@ @[%a@]@ then@ @[%a@]@ else@ @[%a@]@]" format_with_parens cond format_with_parens etrue format_with_parens efalse - | EAppOp { op; args; _ } -> + | EAppOp { op = op, pos; args; _ } -> Format.fprintf fmt "@[%s@ %t%a@]" (Operator.name op) (fun ppf -> match op with | Map2 | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur | Lt_dur_dur | Lte_dur_dur | Gt_dur_dur | Gte_dur_dur | Eq_dur_dur -> - Format.fprintf ppf "%a@ " format_pos (Expr.pos e) + Format.fprintf ppf "%a@ " format_pos pos | _ -> ()) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index 81dfe225..f059eb18 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -126,26 +126,44 @@ let neg_op = function | Op.Gte_dur_dur -> Some Op.Lt_dur_dur | _ -> None -let rec bool_negation e = +let rec bool_negation pos e = match Expr.skip_wrappers e with | ELit (LBool true), m -> ELit (LBool false), m | ELit (LBool false), m -> ELit (LBool true), m - | EAppOp { op = Op.Not; args = [(e, _)] }, m -> e, m - | (EAppOp { op; tys; args = [e1; e2] }, m) as e -> ( + | EAppOp { op = Op.Not, _; args = [(e, _)] }, m -> e, m + | (EAppOp { op = op, opos; tys; args = [e1; e2] }, m) as e -> ( match op with | Op.And -> - EAppOp { op = Op.Or; tys; args = [bool_negation e1; bool_negation e2] }, m + ( EAppOp + { + op = Op.Or, opos; + tys; + args = [bool_negation pos e1; bool_negation pos e2]; + }, + m ) | Op.Or -> - ( EAppOp { op = Op.And; tys; args = [bool_negation e1; bool_negation e2] }, + ( EAppOp + { + op = Op.And, opos; + tys; + args = [bool_negation pos e1; bool_negation pos e2]; + }, m ) | op -> ( match neg_op op with - | Some op -> EAppOp { op; tys; args = [e1; e2] }, m + | Some op -> EAppOp { op = op, opos; tys; args = [e1; e2] }, m | None -> - ( EAppOp { op = Op.Not; tys = [TLit TBool, Expr.mark_pos m]; args = [e] }, + ( EAppOp + { + op = Op.Not, opos; + tys = [TLit TBool, Expr.mark_pos m]; + args = [e]; + }, m ))) | (_, m) as e -> - EAppOp { op = Op.Not; tys = [TLit TBool, Expr.mark_pos m]; args = [e] }, m + ( EAppOp + { op = Op.Not, pos; tys = [TLit TBool, Expr.mark_pos m]; args = [e] }, + m ) let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t = @@ -169,7 +187,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t let r, env1 = lazy_eval ctx env1 llevel e in env_elt.reduced <- r, env1; r, Env.join env env1 - | EAppOp { op; args; tys }, m -> ( + | EAppOp { op = op, opos; args; tys }, m -> ( if (not llevel.eval_default) && not (List.equal Expr.equal args [ELit LUnit, m]) @@ -192,11 +210,13 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t let pos = Expr.mark_pos m in ( EAppOp { - op = Op.Eq_int_int; + op = Op.Eq_int_int, opos; tys = [TLit TInt, pos; TLit TInt, pos]; args = [ - EAppOp { op = Op.Length; tys = [aty]; args = [arr] }, m; + ( EAppOp + { op = Op.Length, opos; tys = [aty]; args = [arr] }, + m ); ELit (LInt (Runtime.integer_of_int 0)), m; ]; }, @@ -245,7 +265,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t (* We did a transformation (removing the outer operator), but further evaluation may be needed to guarantee that [llevel] is reached *) lazy_eval ctx env { llevel with eval_match = true } e - | _ -> (EAppOp { op; args; tys }, m), env) + | _ -> (EAppOp { op = op, opos; args; tys }, m), env) | _ -> let env, args = List.fold_left_map @@ -254,7 +274,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t env, e) env args in - if not llevel.eval_op then (EAppOp { op; args; tys }, m), env + if not llevel.eval_op then (EAppOp { op = op, opos; args; tys }, m), env else let renv = ref env in (* Dirty workaround returning env and conds from evaluate_operator *) @@ -264,7 +284,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t e in let e = - Interpreter.evaluate_operator eval op m Global.En + Interpreter.evaluate_operator eval (op, opos) m Global.En (* Default language to English but this should not raise any error messages so we don't care. *) args @@ -370,14 +390,14 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t ~extra_pos:(List.map (fun (e, _) -> "", Expr.pos e) excs) "Conflicting exceptions") | EPureDefault e, _ -> lazy_eval ctx env llevel e - | EIfThenElse { cond; etrue; efalse }, _ -> ( + | EIfThenElse { cond; etrue; efalse }, m -> ( match eval_to_value env cond with | (ELit (LBool true), _), _ -> let condition = cond, env in let e, env = lazy_eval ctx env llevel etrue in add_condition ~condition e, env | (ELit (LBool false), m), _ -> ( - let condition = bool_negation cond, env in + let condition = bool_negation (Expr.mark_pos m) cond, env in let e, env = lazy_eval ctx env llevel efalse in match efalse with (* The negated condition is not added for nested [else if] to reduce @@ -541,7 +561,8 @@ let to_graph ctx env expr = let rec aux env g e = (* lazy_eval ctx env (result_level base_vars) e *) match Expr.skip_wrappers e with - | EAppOp { op = ToRat_int | ToRat_mon | ToMoney_rat; args = [arg]; _ }, _ -> + | ( EAppOp { op = (ToRat_int | ToRat_mon | ToMoney_rat), _; args = [arg]; _ }, + _ ) -> aux env g arg (* we skip conversions *) | ELit l, _ -> @@ -659,8 +680,9 @@ let program_to_graph in let e = Mark.set m (Expr.skip_wrappers e) in match e with - | EAppOp { op = ToRat_int | ToRat_mon | ToMoney_rat; args = [arg]; tys }, _ - -> + | ( EAppOp + { op = (ToRat_int | ToRat_mon | ToMoney_rat), _; args = [arg]; tys }, + _ ) -> aux parent (g, var_vertices, env0) (Mark.set m arg) (* we skip conversions *) | ELit l, _ -> @@ -698,7 +720,8 @@ let program_to_graph let v = G.V.create e in let g = G.add_vertex g v in (g, var_vertices, env), v)) - | EAppOp { op = Map | Filter | Reduce | Fold; args = _ :: args; _ }, _ -> + | EAppOp { op = (Map | Filter | Reduce | Fold), _; args = _ :: args; _ }, _ + -> (* First argument (which is a function) is ignored *) let v = G.V.create e in let g = G.add_vertex g v in @@ -707,7 +730,7 @@ let program_to_graph in ( (List.fold_left (fun g -> G.add_edge g v) g children, var_vertices, env), v ) - | EAppOp { op; args = [lhs; rhs]; _ }, _ -> + | EAppOp { op = op, _; args = [lhs; rhs]; _ }, _ -> let v = G.V.create e in let g = G.add_vertex g v in let (g, var_vertices, env), lhs = @@ -1221,7 +1244,7 @@ let to_dot lang ppf ctx env base_vars g ~base_src_url = else (* Constants *) [`Style `Filled; `Fillcolor 0x77aaff; `Shape `Note] | EStruct _, _ | EArray _, _ -> [`Shape `Record] - | EAppOp { op; _ }, _ -> ( + | EAppOp { op = op, _; _ }, _ -> ( match op_kind op with | `Sum | `Product | _ -> [`Shape `Box] (* | _ -> [] *)) | _ -> []) diff --git a/compiler/scalc/ast.ml b/compiler/scalc/ast.ml index b605f7d3..7beb09fe 100644 --- a/compiler/scalc/ast.ml +++ b/compiler/scalc/ast.ml @@ -61,7 +61,7 @@ and naked_expr = | EArray of expr list | ELit of lit | EApp of { f : expr; args : expr list } - | EAppOp of { op : operator; args : expr list } + | EAppOp of { op : operator Mark.pos; args : expr list } | EExternal of { modname : VarName.t Mark.pos; name : string Mark.pos } type stmt = diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index f4b0aa57..c80024b7 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -140,7 +140,7 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr = e1_stmts, (A.ETupleAccess { e1 = new_e1; index }, Expr.pos expr) | EAppOp { - op = Op.HandleDefaultOpt; + op = Op.HandleDefaultOpt, _; args = [_exceptions; _just; _cons]; tys = _; } @@ -275,7 +275,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block = e_stmts | EFatalError err -> [SFatalError err, Expr.pos block_expr] | EAppOp - { op = Op.HandleDefaultOpt; tys = _; args = [exceptions; just; cons] } + { op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] } when ctxt.config.keep_special_ops -> let exceptions = match Mark.remove exceptions with diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index 7e46aced..541cdbde 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -74,15 +74,15 @@ let rec format_expr Format.fprintf fmt "@[%a@ %a@]" EnumConstructor.format cons format_expr e | ELit l -> Print.lit fmt l - | EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } -> + | EAppOp { op = ((Map | Filter) as op), _; args = [arg1; arg2] } -> Format.fprintf fmt "@[%a@ %a@ %a@]" (Print.operator ~debug) op format_with_parens arg1 format_with_parens arg2 - | EAppOp { op; args = [arg1; arg2] } -> + | EAppOp { op = op, _; args = [arg1; arg2] } -> Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 (Print.operator ~debug) op format_with_parens arg2 - | EAppOp { op = Log _; args = [arg1] } when not debug -> + | EAppOp { op = Log _, _; args = [arg1] } when not debug -> Format.fprintf fmt "%a" format_with_parens arg1 - | EAppOp { op; args = [arg1] } -> + | EAppOp { op = op, _; args = [arg1] } -> Format.fprintf fmt "@[%a@ %a@]" (Print.operator ~debug) op format_with_parens arg1 | EApp { f; args = [] } -> @@ -93,7 +93,7 @@ let rec format_expr ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) args - | EAppOp { op; args } -> + | EAppOp { op = op, _; args } -> Format.fprintf fmt "@[%a@ %a@]" (Print.operator ~debug) op (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index a308e88c..de698df5 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -350,26 +350,23 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : failwith "should not happen, array initialization is caught at the statement level" | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l) - | EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } -> - Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 (format_expression ctx) arg2 + | EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } -> + Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1 + (format_expression ctx) arg2 | EAppOp { op; args = [arg1; arg2] } -> - Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op - (op, Pos.no_pos) (format_expression ctx) arg2 - | EAppOp { op = Not; args = [arg1] } -> - Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos) - (format_expression ctx) arg1 + Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op + (format_expression ctx) arg2 + | EAppOp { op = (Not, _) as op; args = [arg1] } -> + Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { - op = (Minus_int | Minus_rat | Minus_mon | Minus_dur) as op; + op = ((Minus_int | Minus_rat | Minus_mon | Minus_dur), _) as op; args = [arg1]; } -> - Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 + Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { op; args = [arg1] } -> - Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 - | EAppOp { op = HandleDefaultOpt | HandleDefault; args = _ } -> + Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1 + | EAppOp { op = (HandleDefaultOpt | HandleDefault), _; args = _ } -> failwith "should not happen because of keep_special_ops" | EApp { f; args } -> Format.fprintf fmt "%a(@[%a)@]" (format_expression ctx) f @@ -378,7 +375,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : (format_expression ctx)) args | EAppOp { op; args } -> - Format.fprintf fmt "%a(@[%a)@]" format_op (op, Pos.no_pos) + Format.fprintf fmt "%a(@[%a)@]" format_op op (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (format_expression ctx)) diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 168f4d9c..640094fe 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -298,18 +298,21 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit = (fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e)) es | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l) - | EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } -> - Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 (format_expression ctx) arg2 + | EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } -> + Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1 + (format_expression ctx) arg2 | EAppOp { op; args = [arg1; arg2] } -> - Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op - (op, Pos.no_pos) (format_expression ctx) arg2 + Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op + (format_expression ctx) arg2 | EApp - { f = EAppOp { op = Log (BeginCall, info); args = [f] }, _; args = [arg] } + { + f = EAppOp { op = Log (BeginCall, info), _; args = [f] }, _; + args = [arg]; + } when Global.options.trace -> Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info (format_expression ctx) f (format_expression ctx) arg - | EAppOp { op = Log (VarDef var_def_info, info); args = [arg1] } + | EAppOp { op = Log (VarDef var_def_info, info), _; args = [arg1] } when Global.options.trace -> Format.fprintf fmt "log_variable_definition(%a,@ LogIO(input_io=InputIO.%s,@ \ @@ -321,7 +324,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit = | Runtime.Reentrant -> "Reentrant") (if var_def_info.log_io_output then "True" else "False") (format_expression ctx) arg1 - | EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1] } + | EAppOp { op = Log (PosRecordIfTrueBool, _), _; args = [arg1] } when Global.options.trace -> let pos = Mark.get e in Format.fprintf fmt @@ -330,31 +333,28 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit = (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) (format_expression ctx) arg1 - | EAppOp { op = Log (EndCall, info); args = [arg1] } when Global.options.trace - -> + | EAppOp { op = Log (EndCall, info), _; args = [arg1] } + when Global.options.trace -> Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info (format_expression ctx) arg1 - | EAppOp { op = Log _; args = [arg1] } -> + | EAppOp { op = Log _, _; args = [arg1] } -> Format.fprintf fmt "%a" (format_expression ctx) arg1 - | EAppOp { op = Not; args = [arg1] } -> - Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos) - (format_expression ctx) arg1 + | EAppOp { op = (Not, _) as op; args = [arg1] } -> + Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { - op = (Minus_int | Minus_rat | Minus_mon | Minus_dur) as op; + op = ((Minus_int | Minus_rat | Minus_mon | Minus_dur), _) as op; args = [arg1]; } -> - Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 + Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { op; args = [arg1] } -> - Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 - | EAppOp { op = (HandleDefault | HandleDefaultOpt) as op; args } -> + Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1 + | EAppOp { op = ((HandleDefault | HandleDefaultOpt), _) as op; args } -> let pos = Mark.get e in Format.fprintf fmt "%a(@[SourcePosition(filename=\"%s\",@ start_line=%d,@ \ start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]" - format_op (op, pos) (Pos.get_file pos) (Pos.get_start_line pos) + format_op op (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) (Format.pp_print_list @@ -381,7 +381,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit = (format_expression ctx)) args | EAppOp { op; args } -> - Format.fprintf fmt "%a(@[%a)@]" format_op (op, Pos.no_pos) + Format.fprintf fmt "%a(@[%a)@]" format_op op (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (format_expression ctx)) diff --git a/compiler/scalc/to_r.ml b/compiler/scalc/to_r.ml index 00224a81..1a368b0f 100644 --- a/compiler/scalc/to_r.ml +++ b/compiler/scalc/to_r.ml @@ -305,29 +305,26 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : (fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e)) es | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l) - | EAppOp { op = (Map | Filter) as op; args = [arg1; arg2] } -> - Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 (format_expression ctx) arg2 + | EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } -> + Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1 + (format_expression ctx) arg2 | EAppOp { op; args = [arg1; arg2] } -> - Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op - (op, Pos.no_pos) (format_expression ctx) arg2 - | EAppOp { op = Not; args = [arg1] } -> - Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos) - (format_expression ctx) arg1 + Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op + (format_expression ctx) arg2 + | EAppOp { op = (Not, _) as op; args = [arg1] } -> + Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { - op = (Minus_int | Minus_rat | Minus_mon | Minus_dur) as op; + op = ((Minus_int | Minus_rat | Minus_mon | Minus_dur), _) as op; args = [arg1]; } -> - Format.fprintf fmt "%a %a" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 + Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { op; args = [arg1] } -> - Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos) - (format_expression ctx) arg1 - | EAppOp { op = HandleDefaultOpt; _ } -> + Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1 + | EAppOp { op = HandleDefaultOpt, _; _ } -> Message.error ~internal:true "R compilation does not currently support the avoiding of exceptions" - | EAppOp { op = HandleDefault as op; args; _ } -> + | EAppOp { op = (HandleDefault as op), _; args; _ } -> let pos = Mark.get e in Format.fprintf fmt "%a(@[catala_position(filename=\"%s\",@ start_line=%d,@ \ @@ -359,7 +356,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : (format_expression ctx)) args | EAppOp { op; args } -> - Format.fprintf fmt "%a(@[%a)@]" format_op (op, Pos.no_pos) + Format.fprintf fmt "%a(@[%a)@]" format_op op (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (format_expression ctx)) diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index c9f94079..4c2a2593 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -39,7 +39,7 @@ let tag_with_log_entry (markings : Uid.MarkedString.info list) : untyped Ast.expr boxed = if Global.options.trace then Expr.eappop - ~op:(Log (l, markings)) + ~op:(Log (l, markings), Expr.pos e) ~tys:[TAny, Expr.pos e] ~args:[e] (Mark.get e) else e @@ -200,9 +200,7 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed = ~monomorphic:(fun op -> Expr.eappop ~op ~tys ~args m) ~polymorphic:(fun op -> Expr.eappop ~op ~tys ~args m) ~overloaded:(fun op -> - match - Operator.resolve_overload ctx.decl_ctx (Mark.add (Expr.pos e) op) tys - with + match Operator.resolve_overload ctx.decl_ctx op tys with | op, `Straight -> Expr.eappop ~op ~tys ~args m | op, `Reversed -> Expr.eappop ~op ~tys:(List.rev tys) ~args:(List.rev args) m) diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 6b8ce875..dcb80d0e 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -472,7 +472,7 @@ and ('a, 'b, 'm) base_gexpr = } -> ('a, < .. >, 'm) base_gexpr | EAppOp : { - op : 'a operator; + op : 'a operator Mark.pos; args : ('a, 'm) gexpr list; tys : typ list; } diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index 51fcc654..a4c72eeb 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -300,7 +300,9 @@ let runtime_to_pos rpos = let map (type a b) ?(typ : typ -> typ = Fun.id) - ?op:(fop = (fun _ -> invalid_arg "Expr.map" : a Operator.t -> b Operator.t)) + ?op:(fop = + (fun _ -> invalid_arg "Expr.map" + : a Operator.t Mark.pos -> b Operator.t Mark.pos)) ~(f : (a, 'm1) gexpr -> (b, 'm2) boxed_gexpr) (e : ((a, b, 'm1) base_gexpr, 'm2) marked) : (b, 'm2) boxed_gexpr = let m = map_ty typ (Mark.get e) in @@ -648,7 +650,7 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = equal e1 e2 && equal_list args1 args2 && Type.equal_list tys1 tys2 | ( EAppOp { op = op1; args = args1; tys = tys1 }, EAppOp { op = op2; args = args2; tys = tys2 } ) -> - Operator.equal op1 op2 + Mark.equal Operator.equal op1 op2 && equal_list args1 args2 && Type.equal_list tys1 tys2 | EAssert e1, EAssert e2 -> equal e1 e2 @@ -719,7 +721,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = List.compare compare args1 args2 @@< fun () -> List.compare Type.compare tys1 tys2 | EAppOp {op=op1; args=args1; tys=tys1}, EAppOp {op=op2; args=args2; tys=tys2} -> - Operator.compare op1 op2 @@< fun () -> + Mark.compare Operator.compare op1 op2 @@< fun () -> List.compare compare args1 args2 @@< fun () -> List.compare Type.compare tys1 tys2 | EArray a1, EArray a2 -> @@ -845,7 +847,8 @@ let remove_logging_calls e = let rec f e = let e, m = map ~f ~op:Fun.id e in ( Bindlib.box_apply - (function EAppOp { op = Log _; args = [(arg, _)]; _ } -> arg | e -> e) + (function + | EAppOp { op = Log _, _; args = [(arg, _)]; _ } -> arg | e -> e) e, m ) in diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index d96ae337..8d6876f5 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -85,7 +85,7 @@ val eassert : val efatalerror : Runtime.error -> 'm mark -> (< .. >, 'm) boxed_gexpr val eappop : - op:'a operator -> + op:'a operator Mark.pos -> args:('a, 'm) boxed_gexpr list -> tys:typ list -> 'm mark -> @@ -243,7 +243,7 @@ val untype : ('a, 'm) gexpr -> ('a, untyped) boxed_gexpr val map : ?typ:(typ -> typ) -> - ?op:('a operator -> 'b operator) -> + ?op:('a operator Mark.pos -> 'b operator Mark.pos) -> f:(('a, 'm1) gexpr -> ('b, 'm2) boxed_gexpr) -> (('a, 'b, 'm1) base_gexpr, 'm2) marked -> ('b, 'm2) boxed_gexpr diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index a6205483..abc3b768 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -62,7 +62,8 @@ let print_log lang entry infos pos e = (* Todo: this should be handled early when resolving overloads. Here we have proper structural equality, but the OCaml backend for example uses the builtin equality function instead of this. *) -let handle_eq evaluate_operator m lang e1 e2 = +let handle_eq pos evaluate_operator m lang e1 e2 = + let eq_eval = evaluate_operator (Eq, pos) m lang in let open Runtime.Oper in match e1, e2 with | ELit LUnit, ELit LUnit -> true @@ -77,7 +78,7 @@ let handle_eq evaluate_operator m lang e1 e2 = try List.for_all2 (fun e1 e2 -> - match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with + match Mark.remove (eq_eval [e1; e2]) with | ELit (LBool b) -> b | _ -> assert false (* should not happen *)) @@ -87,7 +88,7 @@ let handle_eq evaluate_operator m lang e1 e2 = StructName.equal s1 s2 && StructField.Map.equal (fun e1 e2 -> - match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with + match Mark.remove (eq_eval [e1; e2]) with | ELit (LBool b) -> b | _ -> assert false (* should not happen *)) @@ -98,7 +99,7 @@ let handle_eq evaluate_operator m lang e1 e2 = EnumName.equal en1 en2 && EnumConstructor.equal i1 i2 && - match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with + match Mark.remove (eq_eval [e1; e2]) with | ELit (LBool b) -> b | _ -> assert false (* should not happen *) @@ -108,12 +109,12 @@ let handle_eq evaluate_operator m lang e1 e2 = (* Call-by-value: the arguments are expected to be already evaluated here *) let rec evaluate_operator evaluate_expr - (op : < overloaded : no ; .. > operator) + ((op, opos) : < overloaded : no ; .. > operator Mark.pos) m lang args = let pos = Expr.mark_pos m in - let rpos = Expr.pos_to_runtime pos in + let rpos = Expr.pos_to_runtime opos in let err () = Message.error ~extra_pos: @@ -121,7 +122,7 @@ let rec evaluate_operator ( Format.asprintf "Operator (value %a):" (Print.operator ~debug:true) op, - pos ); + opos ); ] @ List.mapi (fun i arg -> @@ -151,7 +152,7 @@ let rec evaluate_operator Mark.remove e' | (ToClosureEnv | FromClosureEnv), _ -> err () | Eq, [(e1, _); (e2, _)] -> - ELit (LBool (handle_eq (evaluate_operator evaluate_expr) m lang e1 e2)) + ELit (LBool (handle_eq opos (evaluate_operator evaluate_expr) m lang e1 e2)) | Map, [f; (EArray es, _)] -> EArray (List.map @@ -814,12 +815,13 @@ and partially_evaluate_expr_for_assertion_failure_message : args = [e1; e2]; tys; op = - ( And | Or | Xor | Eq | Lt_int_int | Lt_rat_rat | Lt_mon_mon - | Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon - | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon - | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon - | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon - | Eq_dur_dur | Eq_dat_dat ) as op; + ( ( And | Or | Xor | Eq | Lt_int_int | Lt_rat_rat | Lt_mon_mon + | Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon + | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon + | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon + | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon + | Eq_dur_dur | Eq_dat_dat ), + _ ) as op; } -> ( EAppOp { @@ -950,7 +952,8 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list (Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr ~name:Expr.option_enum mark_e) ty_in (Expr.mark_pos mark_e); - Expr.eappop ~op:Operator.ToClosureEnv + Expr.eappop + ~op:(Operator.ToClosureEnv, pos) ~args:[Expr.etuple [] mark_e] ~tys:[TClosureEnv, pos] mark_e; diff --git a/compiler/shared_ast/interpreter.mli b/compiler/shared_ast/interpreter.mli index 018a5384..b6a21894 100644 --- a/compiler/shared_ast/interpreter.mli +++ b/compiler/shared_ast/interpreter.mli @@ -22,7 +22,7 @@ open Definitions val evaluate_operator : ((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) -> - 'a operator -> + 'a operator Mark.pos -> 'm mark -> Global.backend_lang -> ('a, 'm) gexpr list -> diff --git a/compiler/shared_ast/operator.ml b/compiler/shared_ast/operator.ml index 5fa1d5b8..79970768 100644 --- a/compiler/shared_ast/operator.ml +++ b/compiler/shared_ast/operator.ml @@ -330,36 +330,39 @@ let equal t1 t2 = compare t1 t2 = 0 let kind_dispatch : type a. - polymorphic:(< polymorphic : yes ; .. > t -> 'b) -> - monomorphic:(< monomorphic : yes ; .. > t -> 'b) -> - ?overloaded:(< overloaded : yes ; .. > t -> 'b) -> - ?resolved:(< resolved : yes ; .. > t -> 'b) -> - a t -> + polymorphic:(< polymorphic : yes ; .. > t Mark.pos -> 'b) -> + monomorphic:(< monomorphic : yes ; .. > t Mark.pos -> 'b) -> + ?overloaded:(< overloaded : yes ; .. > t Mark.pos -> 'b) -> + ?resolved:(< resolved : yes ; .. > t Mark.pos -> 'b) -> + a t Mark.pos -> 'b = fun ~polymorphic ~monomorphic ?(overloaded = fun _ -> assert false) ?(resolved = fun _ -> assert false) op -> match op with - | ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | And - | Or | Xor ) as op -> + | ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth + | And | Or | Xor ), + _ ) as op -> monomorphic op - | ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold - | HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ) as op - -> + | ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold + | HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ), + _ ) as op -> polymorphic op - | ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt - | Gte ) as op -> + | ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt + | Gte ), + _ ) as op -> overloaded op - | ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon - | ToMoney_rat | Round_rat | Round_mon | Add_int_int | Add_rat_rat - | Add_mon_mon | Add_dat_dur _ | Add_dur_dur | Sub_int_int | Sub_rat_rat - | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur | Sub_dur_dur | Mult_int_int - | Mult_rat_rat | Mult_mon_rat | Mult_dur_int | Div_int_int | Div_rat_rat - | Div_mon_mon | Div_mon_rat | Div_dur_dur | Lt_int_int | Lt_rat_rat - | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat - | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat - | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat - | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat - | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur ) as op -> + | ( ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon + | ToMoney_rat | Round_rat | Round_mon | Add_int_int | Add_rat_rat + | Add_mon_mon | Add_dat_dur _ | Add_dur_dur | Sub_int_int | Sub_rat_rat + | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur | Sub_dur_dur | Mult_int_int + | Mult_rat_rat | Mult_mon_rat | Mult_dur_int | Div_int_int | Div_rat_rat + | Div_mon_mon | Div_mon_rat | Div_dur_dur | Lt_int_int | Lt_rat_rat + | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat + | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat + | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat + | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat + | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur ), + _ ) as op -> resolved op type 'a no_overloads = @@ -371,22 +374,23 @@ type 'a no_overloads = as 'a -let translate (t : 'a no_overloads t) : 'b no_overloads t = +let translate (t : 'a no_overloads t Mark.pos) : 'b no_overloads t Mark.pos = match t with - | ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | And - | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq | Map - | Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat | Minus_mon - | Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat | Round_mon - | Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _ | Add_dur_dur - | Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur - | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int - | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur - | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur - | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur - | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur - | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur - | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur - | FromClosureEnv | ToClosureEnv ) as op -> + | ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth + | And | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq + | Map | Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat + | Minus_mon | Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat + | Round_mon | Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _ + | Add_dur_dur | Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat + | Sub_dat_dur | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat + | Mult_dur_int | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat + | Div_dur_dur | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat + | Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat + | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat + | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat + | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat + | Eq_dur_dur | FromClosureEnv | ToClosureEnv ), + _ ) as op -> op let monomorphic_type ((op : monomorphic t), pos) = @@ -537,8 +541,11 @@ let resolve_overload_aux (op : overloaded t) (operands : typ_lit list) : _ ) -> raise Not_found -let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) : - < resolved : yes ; .. > t * [ `Straight | `Reversed ] = +let resolve_overload + ctx + ((op, pos) : overloaded t Mark.pos) + (operands : typ list) : + < resolved : yes ; .. > t Mark.pos * [ `Straight | `Reversed ] = try let operands = List.map @@ -546,11 +553,12 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) : match Mark.remove t with TLit tl -> tl | _ -> raise Not_found) operands in - resolve_overload_aux (Mark.remove op) operands + let op, direction = resolve_overload_aux op operands in + (op, pos), direction with Not_found -> Message.error ~extra_pos: - (("", Mark.get op) + (("", pos) :: List.map (fun ty -> ( Format.asprintf "Type %a coming from expression:" @@ -559,7 +567,7 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) : operands) "I don't know how to apply operator %a on types %a" (Print.operator ~debug:true) - (Mark.remove op) + op (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf " and@ ") (Print.typ ctx)) @@ -567,4 +575,4 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) : let overload_type ctx (op : overloaded t Mark.pos) (operands : typ list) : typ = let rop = fst (resolve_overload ctx op operands) in - resolved_type (Mark.copy op rop) + resolved_type rop diff --git a/compiler/shared_ast/operator.mli b/compiler/shared_ast/operator.mli index cdae1b9d..9fb21d51 100644 --- a/compiler/shared_ast/operator.mli +++ b/compiler/shared_ast/operator.mli @@ -43,11 +43,11 @@ val name : 'a t -> string symbols, e.g. [+$]. *) val kind_dispatch : - polymorphic:(< polymorphic : yes ; .. > t -> 'b) -> - monomorphic:(< monomorphic : yes ; .. > t -> 'b) -> - ?overloaded:(< overloaded : yes ; .. > t -> 'b) -> - ?resolved:(< resolved : yes ; .. > t -> 'b) -> - 'a t -> + polymorphic:(< polymorphic : yes ; .. > t Mark.pos -> 'b) -> + monomorphic:(< monomorphic : yes ; .. > t Mark.pos -> 'b) -> + ?overloaded:(< overloaded : yes ; .. > t Mark.pos -> 'b) -> + ?resolved:(< resolved : yes ; .. > t Mark.pos -> 'b) -> + 'a t Mark.pos -> 'b (** Calls one of the supplied functions depending on the kind of the operator *) @@ -60,7 +60,7 @@ type 'a no_overloads = as 'a -val translate : 'a no_overloads t -> 'b no_overloads t +val translate : 'a no_overloads t Mark.pos -> 'b no_overloads t Mark.pos (** An identity function that allows translating an operator between different passes that don't change operator types *) @@ -84,7 +84,7 @@ val resolve_overload : decl_ctx -> overloaded t Mark.pos -> typ list -> - < resolved : yes ; .. > t * [ `Straight | `Reversed ] + < resolved : yes ; .. > t Mark.pos * [ `Straight | `Reversed ] (** Some overloads are sugar for an operation with reversed operands, e.g. [TRat * TMoney] is using [mult_mon_rat]. [`Reversed] is returned to signify this case. *) diff --git a/compiler/shared_ast/optimizations.ml b/compiler/shared_ast/optimizations.ml index 6d3bbe0a..c77a985c 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/compiler/shared_ast/optimizations.ml @@ -97,15 +97,15 @@ let rec optimize_expr : the matches and the log calls are not preserved, which would be a good property *) match Mark.remove e with - | EAppOp { op = Not; args = [(ELit (LBool b), _)]; _ } -> + | EAppOp { op = Not, _; args = [(ELit (LBool b), _)]; _ } -> (* reduction of logical not *) ELit (LBool (not b)) - | EAppOp { op = Or; args = [(ELit (LBool b), _); (e, _)]; _ } - | EAppOp { op = Or; args = [(e, _); (ELit (LBool b), _)]; _ } -> + | EAppOp { op = Or, _; args = [(ELit (LBool b), _); (e, _)]; _ } + | EAppOp { op = Or, _; args = [(e, _); (ELit (LBool b), _)]; _ } -> (* reduction of logical or *) if b then ELit (LBool true) else e - | EAppOp { op = And; args = [(ELit (LBool b), _); (e, _)]; _ } - | EAppOp { op = And; args = [(e, _); (ELit (LBool b), _)]; _ } -> + | EAppOp { op = And, _; args = [(ELit (LBool b), _); (e, _)]; _ } + | EAppOp { op = And, _; args = [(e, _); (ELit (LBool b), _)]; _ } -> (* reduction of logical and *) if b then e else ELit (LBool false) | EMatch { e = EInj { e = e'; cons; name = n' }, _; cases; name = n } @@ -140,15 +140,12 @@ let rec optimize_expr : match Mark.remove b1, Mark.remove e2 with | EAbs { binder = b1; _ }, EAbs { binder = b2; tys } -> ( let v1, e1 = Bindlib.unmbind b1 in - let[@warning "-8"] [| v1 |] = v1 in match Mark.remove e1 with - | EInj { e = e1; _ } -> + | EInj { e = e1, _; _ } -> Some (Expr.unbox - (Expr.make_abs [| v1 |] - (Expr.rebox - (Bindlib.msubst b2 - ([e1] |> List.map fst |> Array.of_list))) + (Expr.make_abs v1 + (Expr.rebox (Bindlib.msubst b2 [| e1 |])) tys (Expr.pos e2))) | _ -> assert false) | _ -> assert false) @@ -198,13 +195,13 @@ let rec optimize_expr : Mark.remove cons | ( [], ( ( ELit (LBool false) - | EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), + | EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ), _ ) ) -> (* No exceptions and condition false *) EEmpty | ( [except], ( ( ELit (LBool false) - | EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), + | EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ), _ ) ) -> (* Single exception and condition false *) Mark.remove except @@ -213,7 +210,7 @@ let rec optimize_expr : { cond = ( ELit (LBool true), _ - | EAppOp { op = Log _; args = [(ELit (LBool true), _)]; _ }, _ ); + | EAppOp { op = Log _, _; args = [(ELit (LBool true), _)]; _ }, _ ); etrue; _; } -> @@ -222,7 +219,7 @@ let rec optimize_expr : { cond = ( ( ELit (LBool false) - | EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), + | EAppOp { op = Log _, _; args = [(ELit (LBool false), _)]; _ } ), _ ); efalse; _; @@ -233,32 +230,37 @@ let rec optimize_expr : cond; etrue = ( ( ELit (LBool btrue) - | EAppOp { op = Log _; args = [(ELit (LBool btrue), _)]; _ } ), + | EAppOp { op = Log _, _; args = [(ELit (LBool btrue), _)]; _ } ), _ ); efalse = ( ( ELit (LBool bfalse) - | EAppOp { op = Log _; args = [(ELit (LBool bfalse), _)]; _ } ), + | EAppOp { op = Log _, _; args = [(ELit (LBool bfalse), _)]; _ } + ), _ ); } -> if btrue && not bfalse then Mark.remove cond else if (not btrue) && bfalse then EAppOp - { op = Not; tys = [TLit TBool, Expr.mark_pos mark]; args = [cond] } + { + op = Not, Expr.mark_pos mark; + tys = [TLit TBool, Expr.mark_pos mark]; + args = [cond]; + } (* note: this last call eliminates the condition & might skip log calls as well *) else (* btrue = bfalse *) ELit (LBool btrue) - | EAppOp { op = Op.Fold; args = [_f; init; (EArray [], _)]; _ } -> + | EAppOp { op = Op.Fold, _; args = [_f; init; (EArray [], _)]; _ } -> (*reduces a fold with an empty list *) Mark.remove init | EAppOp { - op = Map; + op = (Map, _) as op; args = [ f1; ( EAppOp { - op = Map; + op = Map, _; args = [f2; ls]; tys = [_; ((TArray xty, _) as lsty)]; }, @@ -286,7 +288,7 @@ let rec optimize_expr : in let fg = optimize_expr ctx (Expr.unbox fg) in let mapl = - Expr.eappop ~op:Map + Expr.eappop ~op ~args:[fg; Expr.box ls] ~tys:[Expr.maybe_ty (Mark.get fg); lsty] mark @@ -294,13 +296,13 @@ let rec optimize_expr : Mark.remove (Expr.unbox mapl) | EAppOp { - op = Map; + op = Map, _; args = [ f1; ( EAppOp { - op = Map2; + op = (Map2, _) as op; args = [f2; ls1; ls2]; tys = [ @@ -339,7 +341,7 @@ let rec optimize_expr : in let fg = optimize_expr ctx (Expr.unbox fg) in let mapl = - Expr.eappop ~op:Map2 + Expr.eappop ~op ~args:[fg; Expr.box ls1; Expr.box ls2] ~tys:[Expr.maybe_ty (Mark.get fg); ls1ty; ls2ty] mark @@ -347,7 +349,7 @@ let rec optimize_expr : Mark.remove (Expr.unbox mapl) | EAppOp { - op = Op.Fold; + op = Op.Fold, _; args = [f; init; (EArray [e'], _)]; tys = [_; tinit; (TArray tx, _)]; } -> diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 23a70f7f..513d4910 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -370,7 +370,7 @@ module Precedence = struct match Mark.remove e with | ELit _ -> Contained (* Todo: unop if < 0 *) | EAppOp { op; _ } -> ( - match op with + match Mark.remove op with | Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | Length | Log _ | Minus | Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat | ToRat_int | ToRat_mon | ToMoney | ToMoney_rat | Round @@ -571,16 +571,16 @@ module ExprGen (C : EXPR_PARAM) = struct Format.pp_close_box fmt (); punctuation fmt ")")) xs_tau punctuation "→" (rhs expr) body - | EAppOp { op = (Map | Filter) as op; args = [arg1; arg2]; _ } -> + | EAppOp { op = ((Map | Filter) as op), _; args = [arg1; arg2]; _ } -> Format.fprintf fmt "@[%a %a@ %a@]" operator op (lhs exprc) arg1 (rhs exprc) arg2 - | EAppOp { op = Log _ as op; args = [arg1]; _ } -> + | EAppOp { op = (Log _ as op), _; args = [arg1]; _ } -> Format.fprintf fmt "@[%a@ %a@]" operator op (rhs exprc) arg1 - | EAppOp { op = op0; args = [_; _]; _ } -> + | EAppOp { op = op0, _; args = [_; _]; _ } -> let prec = Precedence.expr e in let rec pr colors fmt = function (* Flatten sequences of the same associative op *) - | EAppOp { op; args = [arg1; arg2]; _ }, _ when op = op0 -> ( + | EAppOp { op = op, _; args = [arg1; arg2]; _ }, _ when op = op0 -> ( (match prec with | Op (And | Or | Mul | Add | Div | Sub) -> lhs pr fmt arg1 | _ -> lhs exprc fmt arg1); @@ -595,9 +595,9 @@ module ExprGen (C : EXPR_PARAM) = struct Format.pp_open_hvbox fmt 0; pr colors fmt e; Format.pp_close_box fmt () - | EAppOp { op; args = [arg1]; _ } -> + | EAppOp { op = op, _; args = [arg1]; _ } -> Format.fprintf fmt "@[%a@ %a@]" operator op (rhs exprc) arg1 - | EAppOp { op; args; _ } -> + | EAppOp { op = op, _; args; _ } -> Format.fprintf fmt "@[%a@ %a@]" operator op (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") @@ -761,7 +761,7 @@ module ExprConciseParam = struct let lit = lit let rec pre_map : type a. (a, 't) gexpr -> (a, 't) gexpr = function - | EAppOp { op = Log _; args = [e]; _ }, _ -> pre_map e + | EAppOp { op = Log _, _; args = [e]; _ }, _ -> pre_map e | e -> e end @@ -951,8 +951,8 @@ let program ?(debug = false) fmt p = (* This function is re-exported from module [Expr], but defined here where it's first needed *) let rec skip_wrappers : type a. (a, 'm) gexpr -> (a, 'm) gexpr = function - | EAppOp { op = Log _; args = [e]; tys = _ }, _ -> skip_wrappers e - | EApp { f = EAppOp { op = Log _; args = [f]; _ }, _; args; tys }, m -> + | EAppOp { op = Log _, _; args = [e]; tys = _ }, _ -> skip_wrappers e + | EApp { f = EAppOp { op = Log _, _; args = [f]; _ }, _; args; tys }, m -> skip_wrappers (EApp { f; args; tys }, m) | EErrorOnEmpty e, _ -> skip_wrappers e | EDefault { excepts = []; just = ELit (LBool true), _; cons = e }, _ -> diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index d05d9206..e4d86da0 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -354,13 +354,11 @@ let polymorphic_op_return_type let resolve_overload_ret_type ~flags (ctx : A.decl_ctx) - e - (op : Operator.overloaded A.operator) + _e + (op : Operator.overloaded A.operator Mark.pos) tys : unionfind_typ = let op_ty = - Operator.overload_type ctx - (Mark.add (Expr.pos e) op) - (List.map (typ_to_ast ~flags) tys) + Operator.overload_type ctx op (List.map (typ_to_ast ~flags) tys) in ast_to_typ (Type.arrow_return op_ty) @@ -887,17 +885,14 @@ and typecheck_expr_top_down : let t_args = List.map ast_to_typ tys in let t_func = unionfind (TArrow (t_args, tau)) in let args = - Operator.kind_dispatch op + Operator.kind_dispatch (Mark.set pos_e op) ~polymorphic:(fun op -> (* Type the operator first, then right-to-left: polymorphic operators are required to allow the resolution of all type variables this way *) if not env.flags.assume_op_types then - unify ctx e (polymorphic_op_type (Mark.add pos_e op)) t_func - else - unify ctx e - (polymorphic_op_return_type ctx e (Mark.add pos_e op) t_args) - tau; + unify ctx e (polymorphic_op_type op) t_func + else unify ctx e (polymorphic_op_return_type ctx e op t_args) tau; List.rev_map2 (typecheck_expr_top_down ctx env) (List.rev t_args) (List.rev args)) @@ -908,15 +903,11 @@ and typecheck_expr_top_down : args') ~monomorphic:(fun op -> (* Here it doesn't matter but may affect the error messages *) - unify ctx e - (ast_to_typ (Operator.monomorphic_type (Mark.add pos_e op))) - t_func; + unify ctx e (ast_to_typ (Operator.monomorphic_type op)) t_func; List.map2 (typecheck_expr_top_down ctx env) t_args args) ~resolved:(fun op -> (* This case should not fail *) - unify ctx e - (ast_to_typ (Operator.resolved_type (Mark.add pos_e op))) - t_func; + unify ctx e (ast_to_typ (Operator.resolved_type op)) t_func; List.map2 (typecheck_expr_top_down ctx env) t_args args) in (* All operator applications are monomorphised at this point *) diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index db38d1bb..60f962ff 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -145,6 +145,7 @@ and literal = | LDate of literal_date and collection_op = + | Member of { element : expression } | Exists of { predicate : lident Mark.pos list * expression } | Forall of { predicate : lident Mark.pos list * expression } | Map of { f : lident Mark.pos list * expression } @@ -175,8 +176,7 @@ and naked_expression = | IfThenElse of expression * expression * expression | Binop of binop Mark.pos * expression * expression | Unop of unop Mark.pos * expression - | CollectionOp of collection_op * expression - | MemCollection of expression * expression + | CollectionOp of collection_op Mark.pos * expression | TestMatchCase of expression * match_case_pattern Mark.pos | FunCall of expression * expression list | ScopeCall of diff --git a/compiler/surface/parser.mly b/compiler/surface/parser.mly index f4dd7817..c75dc880 100644 --- a/compiler/surface/parser.mly +++ b/compiler/surface/parser.mly @@ -232,25 +232,26 @@ let naked_expression == RBRACE ; { StructReplace (e, fields) } -| e1 = expression ; - CONTAINS ; - e2 = expression ; { - MemCollection (e2, e1) +| coll = expression ; + pos = pos(CONTAINS) ; + element = expression ; { + CollectionOp ((Member { element }, pos), coll) } %prec apply -| SUM ; typ = addpos(primitive_typ) ; +| pos = pos(SUM) ; typ = addpos(primitive_typ) ; OF ; coll = expression ; { - CollectionOp (AggregateSum { typ = Mark.remove typ }, coll) + CollectionOp ((AggregateSum { typ = Mark.remove typ }, pos), coll) } %prec apply | f = expression ; - FOR ; i = mbinder ; + pos = pos(FOR) ; i = mbinder ; AMONG ; coll = expression ; { - CollectionOp (Map {f = i, f}, coll) + CollectionOp ((Map {f = i, f}, pos), coll) } %prec apply -| max = minmax ; +| maxp = addpos(minmax) ; OF ; coll = expression ; OR ; IF ; LIST_EMPTY ; THEN ; default = expression ; { - CollectionOp (AggregateExtremum { max; default }, coll) + let max, pos = maxp in + CollectionOp ((AggregateExtremum { max; default }, pos), coll) } %prec apply | op = addpos(unop) ; e = expression ; { Unop (op, e) @@ -260,15 +261,15 @@ let naked_expression == e2 = expression ; { Binop (binop, e1, e2) } -| EXISTS ; i = mbinder ; +| pos = pos(EXISTS) ; i = mbinder ; AMONG ; coll = expression ; SUCH ; THAT ; predicate = expression ; { - CollectionOp (Exists {predicate = i, predicate}, coll) + CollectionOp ((Exists {predicate = i, predicate}, pos), coll) } %prec let_expr -| FOR ; ALL ; i = mbinder ; +| pos = pos(FOR) ; ALL ; i = mbinder ; AMONG ; coll = expression ; WE_HAVE ; predicate = expression ; { - CollectionOp (Forall {predicate = i, predicate}, coll) + CollectionOp ((Forall {predicate = i, predicate}, pos), coll) } %prec let_expr | MATCH ; e = expression ; WITH ; @@ -285,23 +286,23 @@ let naked_expression == IN ; e2 = expression ; { LetIn (ids, e1, e2) } %prec let_expr -| LIST; ids = mbinder ; +| pos = pos(LIST); ids = mbinder ; AMONG ; coll = expression ; SUCH ; THAT ; f = expression ; { - CollectionOp (Filter {f = ids, f}, coll) + CollectionOp ((Filter {f = ids, f}, pos), coll) } %prec top_expr | fmap = expression ; - FOR ; i = mbinder ; + pfor = pos(FOR) ; i = mbinder ; AMONG ; coll = expression ; - SUCH ; THAT ; ffilt = expression ; { - CollectionOp (Map {f = i, fmap}, (CollectionOp (Filter {f = i, ffilt}, coll), Pos.from_lpos $loc)) + psuch = pos(SUCH) ; THAT ; ffilt = expression ; { + CollectionOp ((Map {f = i, fmap}, pfor), (CollectionOp ((Filter {f = i, ffilt}, psuch), coll), Pos.from_lpos $loc)) } %prec top_expr -| CONTENT; OF; ids = mbinder ; +| pos = pos(CONTENT); OF; ids = mbinder ; AMONG ; coll = expression ; SUCH ; THAT ; f = expression ; IS ; max = minmax ; OR ; IF ; LIST_EMPTY ; THEN ; default = expression ; { - CollectionOp (AggregateArgExtremum { max; default; f = ids, f }, coll) + CollectionOp ((AggregateArgExtremum { max; default; f = ids, f }, pos), coll) } %prec top_expr diff --git a/compiler/verification/conditions.ml b/compiler/verification/conditions.ml index 5d0b6f4a..5c121a1c 100644 --- a/compiler/verification/conditions.ml +++ b/compiler/verification/conditions.ml @@ -40,7 +40,7 @@ let rec conjunction_exprs (exprs : typed expr list) (mark : typed mark) : | hd :: tl -> ( EAppOp { - op = And; + op = And, Expr.mark_pos mark; tys = [TLit TBool, Expr.pos hd; TLit TBool, Expr.pos hd]; args = [hd; conjunction_exprs tl mark]; }, @@ -54,7 +54,7 @@ let conjunction (args : vc_return list) (mark : typed mark) : vc_return = (fun acc arg -> ( EAppOp { - op = And; + op = And, Expr.mark_pos mark; tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg]; args = [arg; acc]; }, @@ -62,7 +62,13 @@ let conjunction (args : vc_return list) (mark : typed mark) : vc_return = acc list let negation (arg : vc_return) (mark : typed mark) : vc_return = - EAppOp { op = Not; tys = [TLit TBool, Expr.pos arg]; args = [arg] }, mark + ( EAppOp + { + op = Not, Expr.mark_pos mark; + tys = [TLit TBool, Expr.pos arg]; + args = [arg]; + }, + mark ) let disjunction (args : vc_return list) (mark : typed mark) : vc_return = let acc, list = @@ -72,7 +78,7 @@ let disjunction (args : vc_return list) (mark : typed mark) : vc_return = (fun (acc : vc_return) arg -> ( EAppOp { - op = Or; + op = Or, Expr.mark_pos mark; tys = [TLit TBool, Expr.pos acc; TLit TBool, Expr.pos arg]; args = [arg; acc]; }, diff --git a/compiler/verification/z3backend.real.ml b/compiler/verification/z3backend.real.ml index 6bd1b7b1..68725c05 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -432,15 +432,15 @@ let is_leap_year = Runtime.is_leap_year (** [translate_op] returns the Z3 expression corresponding to the application of [op] to the arguments [args] **) let rec translate_op : - context -> dcalc operator -> 'm expr list -> context * Expr.expr = - fun ctx op args -> + context -> dcalc operator Mark.pos -> 'm expr list -> context * Expr.expr = + fun ctx (op, pos) args -> let ill_formed () = Format.kasprintf failwith "[Z3 encoding] Ill-formed operator application: %a" Shared_ast.Expr.format - (Shared_ast.Expr.eappop ~op + (Shared_ast.Expr.eappop ~op:(op, pos) ~args:(List.map Shared_ast.Expr.untype args) ~tys:[] - (Untyped { pos = Pos.no_pos }) + (Untyped { pos }) |> Shared_ast.Expr.unbox) in let app f = @@ -458,7 +458,7 @@ let rec translate_op : failwith "[Z3 encoding] ternary operator application not supported" (* Special case for GetYear comparisons *) | ( Lt_int_int, - [(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> + [(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> let n = Runtime.integer_to_int n in let ctx, e1 = translate_expr ctx e1 in let e2 = @@ -469,7 +469,7 @@ let rec translate_op : days *) ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2 | ( Lte_int_int, - [(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> + [(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> let ctx, e1 = translate_expr ctx e1 in let nb_days = if is_leap_year n then 365 else 364 in let n = Runtime.integer_to_int n in @@ -483,7 +483,7 @@ let rec translate_op : in ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2 | ( Gt_int_int, - [(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> + [(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> let ctx, e1 = translate_expr ctx e1 in let nb_days = if is_leap_year n then 365 else 364 in let n = Runtime.integer_to_int n in @@ -497,7 +497,7 @@ let rec translate_op : in ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2 | ( Gte_int_int, - [(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> + [(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] ) -> let n = Runtime.integer_to_int n in let ctx, e1 = translate_expr ctx e1 in let e2 = @@ -507,7 +507,7 @@ let rec translate_op : be directly translated as >= in the Z3 encoding using the number of days *) ctx, Arithmetic.mk_ge ctx.ctx_z3 e1 e2 - | Eq, [(EAppOp { op = GetYear; args = [e1]; _ }, _); (ELit (LInt n), _)] -> + | Eq, [(EAppOp { op = GetYear, _; args = [e1]; _ }, _); (ELit (LInt n), _)] -> let n = Runtime.integer_to_int n in let ctx, e1 = translate_expr ctx e1 in let min_date = diff --git a/tests/arithmetic/bad/division_by_zero.catala_en b/tests/arithmetic/bad/division_by_zero.catala_en index 4022c9cc..ae6fd562 100644 --- a/tests/arithmetic/bad/division_by_zero.catala_en +++ b/tests/arithmetic/bad/division_by_zero.catala_en @@ -32,54 +32,39 @@ scope Money: ```catala-test-inline -$ catala Interpret -s Dec +$ catala test-scope Dec [ERROR] Error during evaluation: division by zero. -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:20.23-20.30: +┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:20.26-20.27: └──┐ 20 │ definition i equals 1. / 0. - │ ‾‾‾‾‾‾‾ - └┬ `Division_by_zero` exception management - └─ with decimals -#return code 123# -``` - - -Fixme: the following should give the same result as above, but the optimisation pass propagates the position surrounding the `ErrorOnEmpty` and loses the position of the actual division expression which was in the `cons` of the default term. Unfortunately this is non-trivial due to the bindlib boxing tricks. -```catala-test-inline -$ catala Interpret -O -s Dec -[ERROR] Error during evaluation: division by zero. - -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:17.10-17.11: -└──┐ -17 │ output i content decimal - │ ‾ + │ ‾ └┬ `Division_by_zero` exception management └─ with decimals #return code 123# ``` ```catala-test-inline -$ catala interpret -s Int +$ catala test-scope Int [ERROR] Error during evaluation: division by zero. -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:10.23-10.28: +┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:10.25-10.26: └──┐ 10 │ definition i equals 1 / 0 - │ ‾‾‾‾‾ + │ ‾ └┬ `Division_by_zero` exception management └─ with integers #return code 123# ``` ```catala-test-inline -$ catala Interpret -s Money +$ catala test-scope Money [ERROR] Error during evaluation: division by zero. -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:30.23-30.35: +┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:30.29-30.30: └──┐ 30 │ definition i equals $10.0 / $0.0 - │ ‾‾‾‾‾‾‾‾‾‾‾‾ + │ ‾ └┬ `Division_by_zero` exception management └─ with money #return code 123# diff --git a/tests/date/bad/uncomparable_duration.catala_en b/tests/date/bad/uncomparable_duration.catala_en index 9169310d..308dc2b6 100644 --- a/tests/date/bad/uncomparable_duration.catala_en +++ b/tests/date/bad/uncomparable_duration.catala_en @@ -49,10 +49,10 @@ $ catala interpret -s Ge [ERROR] Error during evaluation: comparing durations in different units (e.g. months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:40.23-40.39: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:40.31-40.33: └──┐ 40 │ definition d equals 1 month >= 2 day - │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + │ ‾‾ └┬ `UncomparableDurations` exception management └─ `>=` operator #return code 123# @@ -63,10 +63,10 @@ $ catala interpret -s Gt [ERROR] Error during evaluation: comparing durations in different units (e.g. months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:30.23-30.38: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:30.31-30.32: └──┐ 30 │ definition d equals 1 month > 2 day - │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + │ ‾ └┬ `UncomparableDurations` exception management └─ `<=` operator #return code 123# @@ -77,10 +77,10 @@ $ catala interpret -s Le [ERROR] Error during evaluation: comparing durations in different units (e.g. months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:20.23-20.39: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:20.31-20.33: └──┐ 20 │ definition d equals 1 month <= 2 day - │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + │ ‾‾ └┬ `UncomparableDurations` exception management └─ `<=` operator #return code 123# @@ -91,10 +91,10 @@ $ catala interpret -s Lt [ERROR] Error during evaluation: comparing durations in different units (e.g. months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:10.23-10.38: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:10.31-10.32: └──┐ 10 │ definition d equals 1 month < 2 day - │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + │ ‾ └┬ `UncomparableDurations` exception management └─ `<` operator #return code 123# diff --git a/tests/modules/good/output/mod_def.ml b/tests/modules/good/output/mod_def.ml index 92399cd0..9d0cc225 100644 --- a/tests/modules/good/output/mod_def.ml +++ b/tests/modules/good/output/mod_def.ml @@ -66,7 +66,7 @@ let half_ : integer -> decimal = fun (x_: integer) -> o_div_int_int {filename="tests/modules/good/mod_def.catala_en"; - start_line=21; start_column=10; end_line=21; end_column=15; + start_line=21; start_column=12; end_line=21; end_column=13; law_headings=["Test modules + inclusions 1"]} x_ (integer_of_string "2")