mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-19 00:15:39 +03:00
More precise positions for operators throughout
This commit is contained in:
parent
50d686f089
commit
cee8e57d02
@ -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 ->
|
||||||
|
@ -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 }
|
||||||
|
@ -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;
|
||||||
} ->
|
} ->
|
||||||
|
@ -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;
|
||||||
|
@ -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;
|
||||||
|
@ -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 "@ ")
|
||||||
|
@ -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] (* | _ -> [] *))
|
||||||
| _ -> [])
|
| _ -> [])
|
||||||
|
@ -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 =
|
||||||
|
@ -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
|
||||||
|
@ -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 "@ ")
|
||||||
|
@ -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))
|
||||||
|
@ -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))
|
||||||
|
@ -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))
|
||||||
|
@ -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)
|
||||||
|
@ -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;
|
||||||
}
|
}
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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;
|
||||||
|
@ -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 ->
|
||||||
|
@ -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
|
||||||
|
@ -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. *)
|
||||||
|
@ -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, _)];
|
||||||
} ->
|
} ->
|
||||||
|
@ -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 }, _ ->
|
||||||
|
@ -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 *)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
|
||||||
|
@ -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];
|
||||||
},
|
},
|
||||||
|
@ -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 =
|
||||||
|
@ -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#
|
||||||
|
@ -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#
|
||||||
|
@ -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")
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user