CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

AST refactoring (#356)

Browse Source
This commit is contained in:
Louis Gesbert 2022-11-22 11:08:11 +01:00 committed by GitHub
commit 6ecca5c664
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
59 changed files with 3571 additions and 3472 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
build_system/clerk_driver.ml
View File

@ -524,7 +524,7 @@ let collect_all_ninja_build
(tested_file : string)
(reset_test_outputs : bool) : (string * ninja) option =
let expected_outputs = search_for_expected_outputs tested_file in
if List.length expected_outputs = 0 then (
if expected_outputs = [] then (
Cli.debug_print "No expected outputs were found for test file %s"
tested_file;
None)

171
compiler/dcalc/interpreter.ml
View File

@ -69,7 +69,9 @@ let rec evaluate_operator
(List.fold_left
(fun acc e' ->
evaluate_expr ctx
(Marked.same_mark_as (EApp (List.nth args 0, [acc; e'])) e'))
(Marked.same_mark_as
(EApp { f = List.nth args 0; args = [acc; e'] })
e'))
(List.nth args 1) es)
| Binop And, [ELit (LBool b1); ELit (LBool b2)] -> ELit (LBool (b1 && b2))
| Binop Or, [ELit (LBool b1); ELit (LBool b2)] -> ELit (LBool (b1 || b2))
@ -172,25 +174,29 @@ let rec evaluate_operator
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| Binop Eq, [ETuple (es1, s1); ETuple (es2, s2)] ->
| ( Binop Eq,
[EStruct { fields = es1; name = s1 }; EStruct { fields = es2; name = s2 }]
) ->
ELit
(LBool
(StructName.equal s1 s2
&& StructFieldMap.equal
(fun e1 e2 ->
match evaluate_operator ctx op pos [e1; e2] with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2))
| ( Binop Eq,
[
EInj { e = e1; cons = i1; name = en1 };
EInj { e = e2; cons = i2; name = en2 };
] ) ->
ELit
(LBool
(try
s1 = s2
&& List.for_all2
(fun e1 e2 ->
match evaluate_operator ctx op pos [e1; e2] with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| Binop Eq, [EInj (e1, i1, en1, _ts1); EInj (e2, i2, en2, _ts2)] ->
ELit
(LBool
(try
en1 = en2
&& i1 = i2
EnumName.equal en1 en2
&& EnumConstructor.equal i1 i2
&&
match evaluate_operator ctx op pos [e1; e2] with
| ELit (LBool b) -> b
@ -209,7 +215,7 @@ let rec evaluate_operator
(List.map
(fun e' ->
evaluate_expr ctx
(Marked.same_mark_as (EApp (List.nth args 0, [e'])) e'))
(Marked.same_mark_as (EApp { f = List.hd args; args = [e'] }) e'))
es)
| Binop Filter, [_; EArray es] ->
EArray
@ -217,7 +223,7 @@ let rec evaluate_operator
(fun e' ->
match
evaluate_expr ctx
(Marked.same_mark_as (EApp (List.nth args 0, [e'])) e')
(Marked.same_mark_as (EApp { f = List.hd args; args = [e'] }) e')
with
| ELit (LBool b), _ -> b
| _ ->
@ -314,11 +320,11 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
Errors.raise_spanned_error (Expr.pos e)
"free variable found at evaluation (should not happen if term was \
well-typed"
| EApp (e1, args) -> (
| EApp { f = e1; args } -> (
let e1 = evaluate_expr ctx e1 in
let args = List.map (evaluate_expr ctx) args in
match Marked.unmark e1 with
| EAbs (binder, _) ->
| EAbs { binder; _ } ->
if Bindlib.mbinder_arity binder = List.length args then
evaluate_expr ctx
(Bindlib.msubst binder (Array.of_list (List.map Marked.unmark args)))
@ -335,69 +341,66 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
"function has not been reduced to a lambda at evaluation (should not \
happen if the term was well-typed")
| EAbs _ | ELit _ | EOp _ -> e (* these are values *)
| ETuple (es, s) ->
let new_es = List.map (evaluate_expr ctx) es in
if List.exists is_empty_error new_es then
| EStruct { fields = es; name } ->
let new_es = StructFieldMap.map (evaluate_expr ctx) es in
if StructFieldMap.exists (fun _ e -> is_empty_error e) new_es then
Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (ETuple (new_es, s)) e
| ETupleAccess (e1, n, s, _) -> (
else Marked.same_mark_as (EStruct { fields = new_es; name }) e
| EStructAccess { e = e1; name = s; field } -> (
let e1 = evaluate_expr ctx e1 in
match Marked.unmark e1 with
| ETuple (es, s') -> (
(match s, s' with
| None, None -> ()
| Some s, Some s' when s = s' -> ()
| _ ->
| EStruct { fields = es; name = s' } -> (
if not (StructName.equal s s') then
Errors.raise_multispanned_error
[None, Expr.pos e; None, Expr.pos e1]
"Error during tuple access: not the same structs (should not happen \
if the term was well-typed)");
match List.nth_opt es n with
"Error during struct access: not the same structs (should not happen \
if the term was well-typed)";
match StructFieldMap.find_opt field es with
| Some e' -> e'
| None ->
Errors.raise_spanned_error (Expr.pos e1)
"The tuple has %d components but the %i-th element was requested \
(should not happen if the term was well-type)"
(List.length es) n)
"Invalid field access %a in struct %a (should not happen if the term \
was well-typed)"
StructFieldName.format_t field StructName.format_t s)
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Expr.pos e1)
"The expression %a should be a tuple with %d components but is not \
(should not happen if the term was well-typed)"
"The expression %a should be a struct %a but is not (should not happen \
if the term was well-typed)"
(Expr.format ctx ~debug:true)
e n)
| EInj (e1, n, en, ts) ->
e StructName.format_t s)
| EInj { e = e1; name; cons } ->
let e1' = evaluate_expr ctx e1 in
if is_empty_error e1' then Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (EInj (e1', n, en, ts)) e
| EMatch (e1, es, e_name) -> (
if is_empty_error e then Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (EInj { e = e1'; name; cons }) e
| EMatch { e = e1; cases = es; name } -> (
let e1 = evaluate_expr ctx e1 in
match Marked.unmark e1 with
| EInj (e1, n, e_name', _) ->
if e_name <> e_name' then
| EInj { e = e1; cons; name = name' } ->
if not (EnumName.equal name name') then
Errors.raise_multispanned_error
[None, Expr.pos e; None, Expr.pos e1]
"Error during match: two different enums found (should not happen if \
the term was well-typed)";
let es_n =
match List.nth_opt es n with
match EnumConstructorMap.find_opt cons es with
| Some es_n -> es_n
| None ->
Errors.raise_spanned_error (Expr.pos e)
"sum type index error (should not happen if the term was \
well-typed)"
in
let new_e = Marked.same_mark_as (EApp (es_n, [e1])) e in
let new_e = Marked.same_mark_as (EApp { f = es_n; args = [e1] }) e in
evaluate_expr ctx new_e
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Expr.pos e1)
"Expected a term having a sum type as an argument to a match (should \
not happen if the term was well-typed")
| EDefault (exceptions, just, cons) -> (
let exceptions = List.map (evaluate_expr ctx) exceptions in
let empty_count = List.length (List.filter is_empty_error exceptions) in
match List.length exceptions - empty_count with
| EDefault { excepts; just; cons } -> (
let excepts = List.map (evaluate_expr ctx) excepts in
let empty_count = List.length (List.filter is_empty_error excepts) in
match List.length excepts - empty_count with
| 0 -> (
let just = evaluate_expr ctx just in
match Marked.unmark just with
@ -408,19 +411,19 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
Errors.raise_spanned_error (Expr.pos e)
"Default justification has not been reduced to a boolean at \
evaluation (should not happen if the term was well-typed")
| 1 -> List.find (fun sub -> not (is_empty_error sub)) exceptions
| 1 -> List.find (fun sub -> not (is_empty_error sub)) excepts
| _ ->
Errors.raise_multispanned_error
(List.map
(fun except ->
Some "This consequence has a valid justification:", Expr.pos except)
(List.filter (fun sub -> not (is_empty_error sub)) exceptions))
(List.filter (fun sub -> not (is_empty_error sub)) excepts))
"There is a conflict between multiple valid consequences for assigning \
the same variable.")
| EIfThenElse (cond, et, ef) -> (
| EIfThenElse { cond; etrue; efalse } -> (
match Marked.unmark (evaluate_expr ctx cond) with
| ELit (LBool true) -> evaluate_expr ctx et
| ELit (LBool false) -> evaluate_expr ctx ef
| ELit (LBool true) -> evaluate_expr ctx etrue
| ELit (LBool false) -> evaluate_expr ctx efalse
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Expr.pos cond)
@ -431,7 +434,7 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
if List.exists is_empty_error new_es then
Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (EArray new_es) e
| ErrorOnEmpty e' ->
| EErrorOnEmpty e' ->
let e' = evaluate_expr ctx e' in
if Marked.unmark e' = ELit LEmptyError then
Errors.raise_spanned_error (Expr.pos e')
@ -443,20 +446,31 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
| ELit (LBool true) -> Marked.same_mark_as (ELit LUnit) e'
| ELit (LBool false) -> (
match Marked.unmark e' with
| ErrorOnEmpty
| EErrorOnEmpty
( EApp
((EOp (Binop op), _), [((ELit _, _) as e1); ((ELit _, _) as e2)]),
{
f = EOp (Binop op), _;
args = [((ELit _, _) as e1); ((ELit _, _) as e2)];
},
_ )
| EApp
( (EOp (Unop (Log _)), _),
[
( EApp
( (EOp (Binop op), _),
[((ELit _, _) as e1); ((ELit _, _) as e2)] ),
_ );
] )
| EApp ((EOp (Binop op), _), [((ELit _, _) as e1); ((ELit _, _) as e2)])
->
{
f = EOp (Unop (Log _)), _;
args =
[
( EApp
{
f = EOp (Binop op), _;
args = [((ELit _, _) as e1); ((ELit _, _) as e2)];
},
_ );
];
}
| EApp
{
f = EOp (Binop op), _;
args = [((ELit _, _) as e1); ((ELit _, _) as e2)];
} ->
Errors.raise_spanned_error (Expr.pos e') "Assertion failed: %a %a %a"
(Expr.format ctx ~debug:false)
e1 Print.binop op
@ -479,7 +493,7 @@ let interpret_program :
fun (ctx : decl_ctx) (e : 'm Ast.expr) :
(Uid.MarkedString.info * 'm Ast.expr) list ->
match evaluate_expr ctx e with
| (EAbs (_, [((TStruct s_in, _) as _targs)]), mark_e) as e -> begin
| (EAbs { tys = [((TStruct s_in, _) as _targs)]; _ }, mark_e) as e -> begin
(* At this point, the interpreter seeks to execute the scope but does not
have a way to retrieve input values from the command line. [taus] contain
the types of the scope arguments. For [context] arguments, we can provide
@ -487,8 +501,8 @@ let interpret_program :
cannot provide anything so we have to fail. *)
let taus = StructMap.find s_in ctx.ctx_structs in
let application_term =
List.map
(fun (_, ty) ->
StructFieldMap.map
(fun ty ->
match Marked.unmark ty with
| TArrow ((TLit TUnit, _), ty_in) ->
Expr.empty_thunked_term (Expr.with_ty mark_e ty_in)
@ -503,17 +517,14 @@ let interpret_program :
in
let to_interpret =
Expr.make_app (Expr.box e)
[Expr.make_tuple application_term (Some s_in) mark_e]
[Expr.estruct s_in application_term mark_e]
(Expr.pos e)
in
match Marked.unmark (evaluate_expr ctx (Expr.unbox to_interpret)) with
| ETuple (args, Some s_out) ->
let s_out_fields =
List.map
(fun (f, _) -> StructFieldName.get_info f)
(StructMap.find s_out ctx.ctx_structs)
in
List.map2 (fun arg var -> var, arg) args s_out_fields
| EStruct { fields; _ } ->
List.map
(fun (fld, e) -> StructFieldName.get_info fld, e)
(StructFieldMap.bindings fields)
| _ ->
Errors.raise_spanned_error (Expr.pos e)
"The interpretation of a program should always yield a struct \

312
compiler/dcalc/optimizations.ml
View File

@ -24,179 +24,185 @@ type partial_evaluation_ctx = {
}
let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm expr) :
'm expr Bindlib.box =
(dcalc, 'm mark) boxed_gexpr =
(* We proceed bottom-up, first apply on the subterms *)
let e = Expr.map ~f:(partial_evaluation ctx) e in
let mark = Marked.get_mark e in
let rec_helper = partial_evaluation ctx in
match Marked.unmark e with
| EApp
( (( EOp (Unop Not), _
| EApp ((EOp (Unop (Log _)), _), [(EOp (Unop Not), _)]), _ ) as op),
[e1] ) ->
(* reduction of logical not *)
(Bindlib.box_apply (fun e1 ->
match e1 with
| ELit (LBool false), _ -> ELit (LBool true), mark
| ELit (LBool true), _ -> ELit (LBool false), mark
| _ -> EApp (op, [e1]), mark))
(rec_helper e1)
| EApp
( (( EOp (Binop Or), _
| EApp ((EOp (Unop (Log _)), _), [(EOp (Binop Or), _)]), _ ) as op),
[e1; e2] ) ->
(* reduction of logical or *)
(Bindlib.box_apply2 (fun e1 e2 ->
match e1, e2 with
| (ELit (LBool false), _), new_e | new_e, (ELit (LBool false), _) ->
new_e
| (ELit (LBool true), _), _ | _, (ELit (LBool true), _) ->
ELit (LBool true), mark
| _ -> EApp (op, [e1; e2]), mark))
(rec_helper e1) (rec_helper e2)
| EApp
( (( EOp (Binop And), _
| EApp ((EOp (Unop (Log _)), _), [(EOp (Binop And), _)]), _ ) as op),
[e1; e2] ) ->
(* reduction of logical and *)
(Bindlib.box_apply2 (fun e1 e2 ->
match e1, e2 with
| (ELit (LBool true), _), new_e | new_e, (ELit (LBool true), _) ->
new_e
| (ELit (LBool false), _), _ | _, (ELit (LBool false), _) ->
ELit (LBool false), mark
| _ -> EApp (op, [e1; e2]), mark))
(rec_helper e1) (rec_helper e2)
| EVar x -> Bindlib.box_apply (fun x -> x, mark) (Bindlib.box_var x)
| ETuple (args, s_name) ->
Bindlib.box_apply
(fun args -> ETuple (args, s_name), mark)
(List.map rec_helper args |> Bindlib.box_list)
| ETupleAccess (arg, i, s_name, typs) ->
Bindlib.box_apply
(fun arg -> ETupleAccess (arg, i, s_name, typs), mark)
(rec_helper arg)
| EInj (arg, i, e_name, typs) ->
Bindlib.box_apply
(fun arg -> EInj (arg, i, e_name, typs), mark)
(rec_helper arg)
| EMatch (arg, arms, e_name) ->
Bindlib.box_apply2
(fun arg arms ->
match arg, arms with
| (EInj (e1, i, e_name', _ts), _), _
when EnumName.compare e_name e_name' = 0 ->
(* iota reduction *)
EApp (List.nth arms i, [e1]), mark
| _ -> EMatch (arg, arms, e_name), mark)
(rec_helper arg)
(List.map rec_helper arms |> Bindlib.box_list)
| EArray args ->
Bindlib.box_apply
(fun args -> EArray args, mark)
(List.map rec_helper args |> Bindlib.box_list)
| ELit l -> Bindlib.box (ELit l, mark)
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
let new_body = rec_helper body in
let new_binder = Bindlib.bind_mvar vars new_body in
Bindlib.box_apply (fun binder -> EAbs (binder, typs), mark) new_binder
| EApp (f, args) ->
Bindlib.box_apply2
(fun f args ->
match Marked.unmark f with
| EAbs (binder, _ts) ->
(* beta reduction *)
Bindlib.msubst binder (List.map fst args |> Array.of_list)
| _ -> EApp (f, args), mark)
(rec_helper f)
(List.map rec_helper args |> Bindlib.box_list)
| EAssert e1 -> Bindlib.box_apply (fun e1 -> EAssert e1, mark) (rec_helper e1)
| EOp op -> Bindlib.box (EOp op, mark)
| EDefault (exceptions, just, cons) ->
Bindlib.box_apply3
(fun exceptions just cons ->
(* TODO: mechanically prove each of these optimizations correct :) *)
match
( List.filter
(fun except ->
match Marked.unmark except with
| ELit LEmptyError -> false
| _ -> true)
exceptions
(* we can discard the exceptions that are always empty error *),
just,
cons )
with
| exceptions, just, cons
when List.fold_left
(fun nb except -> if Expr.is_value except then nb + 1 else nb)
0 exceptions
> 1 ->
(* at this point we know a conflict error will be triggered so we just
feed the expression to the interpreter that will print the
beautiful right error message *)
Interpreter.evaluate_expr ctx.decl_ctx
(EDefault (exceptions, just, cons), mark)
| [except], _, _ when Expr.is_value except ->
(* Then reduce the parent node *)
let reduce e =
(* Todo: improve the handling of eapp(log,elit) cases here, it obfuscates
the matches and the log calls are not preserved, which would be a good
property *)
match Marked.unmark e with
| EApp
{
f =
( EOp (Unop Not), _
| ( EApp { f = EOp (Unop (Log _)), _; args = [(EOp (Unop Not), _)] },
_ ) ) as op;
args = [e1];
} -> (
(* reduction of logical not *)
match e1 with
| ELit (LBool false), _ -> ELit (LBool true)
| ELit (LBool true), _ -> ELit (LBool false)
| e1 -> EApp { f = op; args = [e1] })
| EApp
{
f =
( EOp (Binop Or), _
| ( EApp { f = EOp (Unop (Log _)), _; args = [(EOp (Binop Or), _)] },
_ ) ) as op;
args = [e1; e2];
} -> (
(* reduction of logical or *)
match e1, e2 with
| (ELit (LBool false), _), new_e | new_e, (ELit (LBool false), _) ->
Marked.unmark new_e
| (ELit (LBool true), _), _ | _, (ELit (LBool true), _) ->
ELit (LBool true)
| _ -> EApp { f = op; args = [e1; e2] })
| EApp
{
f =
( EOp (Binop And), _
| ( EApp { f = EOp (Unop (Log _)), _; args = [(EOp (Binop And), _)] },
_ ) ) as op;
args = [e1; e2];
} -> (
(* reduction of logical and *)
match e1, e2 with
| (ELit (LBool true), _), new_e | new_e, (ELit (LBool true), _) ->
Marked.unmark new_e
| (ELit (LBool false), _), _ | _, (ELit (LBool false), _) ->
ELit (LBool false)
| _ -> EApp { f = op; args = [e1; e2] })
| EMatch { e = EInj { e; name = name1; cons }, _; cases; name }
when EnumName.equal name name1 ->
(* iota reduction *)
EApp { f = EnumConstructorMap.find cons cases; args = [e] }
| EApp { f = EAbs { binder; _ }, _; args } ->
(* beta reduction *)
Marked.unmark (Bindlib.msubst binder (List.map fst args |> Array.of_list))
| EDefault { excepts; just; cons } -> (
(* TODO: mechanically prove each of these optimizations correct :) *)
let excepts =
List.filter
(fun except -> Marked.unmark except <> ELit LEmptyError)
excepts
(* we can discard the exceptions that are always empty error *)
in
let value_except_count =
List.fold_left
(fun nb except -> if Expr.is_value except then nb + 1 else nb)
0 excepts
in
if value_except_count > 1 then
(* at this point we know a conflict error will be triggered so we just
feed the expression to the interpreter that will print the beautiful
right error message *)
Marked.unmark (Interpreter.evaluate_expr ctx.decl_ctx e)
else
match excepts, just with
| [except], _ when Expr.is_value except ->
(* if there is only one exception and it is a non-empty value it is
always chosen *)
except
Marked.unmark except
| ( [],
( ( ELit (LBool true)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool true), _)]) ),
_ ),
cons ) ->
cons
| EApp
{ f = EOp (Unop (Log _)), _; args = [(ELit (LBool true), _)] }
),
_ ) ) ->
Marked.unmark cons
| ( [],
( ( ELit (LBool false)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool false), _)]) ),
_ ),
_ ) ->
ELit LEmptyError, mark
| [], just, cons when not !Cli.avoid_exceptions_flag ->
| EApp
{
f = EOp (Unop (Log _)), _;
args = [(ELit (LBool false), _)];
} ),
_ ) ) ->
ELit LEmptyError
| [], just when not !Cli.avoid_exceptions_flag ->
(* without exceptions, a default is just an [if then else] raising an
error in the else case. This exception is only valid in the context
of compilation_with_exceptions, so we desactivate with a global
flag to know if we will be compiling using exceptions or the option
monad. *)
EIfThenElse (just, cons, (ELit LEmptyError, mark)), mark
| exceptions, just, cons -> EDefault (exceptions, just, cons), mark)
(List.map rec_helper exceptions |> Bindlib.box_list)
(rec_helper just) (rec_helper cons)
| EIfThenElse (e1, e2, e3) ->
Bindlib.box_apply3
(fun e1 e2 e3 ->
match Marked.unmark e1, Marked.unmark e2, Marked.unmark e3 with
| ELit (LBool true), _, _
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool true), _)]), _, _ ->
e2
| ELit (LBool false), _, _
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool false), _)]), _, _ ->
e3
| ( _,
( ELit (LBool true)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool true), _)]) ),
( ELit (LBool false)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool false), _)]) ) ) ->
e1
| _ when Expr.equal e2 e3 -> e2
| _ -> EIfThenElse (e1, e2, e3), mark)
(rec_helper e1) (rec_helper e2) (rec_helper e3)
| ErrorOnEmpty e1 ->
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, mark) (rec_helper e1)
monad. FIXME: move this optimisation somewhere else to avoid this
check *)
EIfThenElse
{ cond = just; etrue = cons; efalse = ELit LEmptyError, mark }
| excepts, just -> EDefault { excepts; just; cons })
| EIfThenElse
{
cond =
( ELit (LBool true), _
| ( EApp
{ f = EOp (Unop (Log _)), _; args = [(ELit (LBool true), _)] },
_ ) );
etrue;
_;
} ->
Marked.unmark etrue
| EIfThenElse
{
cond =
( ( ELit (LBool false)
| EApp
{
f = EOp (Unop (Log _)), _;
args = [(ELit (LBool false), _)];
} ),
_ );
efalse;
_;
} ->
Marked.unmark efalse
| EIfThenElse
{
cond;
etrue =
( ( ELit (LBool btrue)
| EApp
{
f = EOp (Unop (Log _)), _;
args = [(ELit (LBool btrue), _)];
} ),
_ );
efalse =
( ( ELit (LBool bfalse)
| EApp
{
f = EOp (Unop (Log _)), _;
args = [(ELit (LBool bfalse), _)];
} ),
_ );
} ->
if btrue && not bfalse then Marked.unmark cond
else if (not btrue) && bfalse then
EApp { f = EOp (Unop Not), mark; args = [cond] }
(* note: this last call eliminates the condition & might skip log calls
as well *)
else (* btrue = bfalse *) ELit (LBool btrue)
| e -> e
in
Expr.Box.app1 e reduce mark
let optimize_expr (decl_ctx : decl_ctx) (e : 'm expr) =
partial_evaluation { var_values = Var.Map.empty; decl_ctx } e
let rec scope_lets_map
(t : 'a -> 'm expr -> 'm expr Bindlib.box)
(t : 'a -> 'm expr -> (dcalc, 'm mark) boxed_gexpr)
(ctx : 'a)
(scope_body_expr : 'm expr scope_body_expr) :
'm expr scope_body_expr Bindlib.box =
match scope_body_expr with
| Result e -> Bindlib.box_apply (fun e' -> Result e') (t ctx e)
| Result e ->
Bindlib.box_apply (fun e' -> Result e') (Expr.Box.lift (t ctx e))
| ScopeLet scope_let ->
let var, next = Bindlib.unbind scope_let.scope_let_next in
let new_scope_let_expr = t ctx scope_let.scope_let_expr in
let new_scope_let_expr = Expr.Box.lift (t ctx scope_let.scope_let_expr) in
let new_next = scope_lets_map t ctx next in
let new_next = Bindlib.bind_var var new_next in
Bindlib.box_apply2
@ -210,7 +216,7 @@ let rec scope_lets_map
new_scope_let_expr new_next
let rec scopes_map
(t : 'a -> 'm expr -> 'm expr Bindlib.box)
(t : 'a -> 'm expr -> (dcalc, 'm mark) boxed_gexpr)
(ctx : 'a)
(scopes : 'm expr scopes) : 'm expr scopes Bindlib.box =
match scopes with
@ -241,7 +247,7 @@ let rec scopes_map
new_scope_body_expr new_scope_next
let program_map
(t : 'a -> 'm expr -> 'm expr Bindlib.box)
(t : 'a -> 'm expr -> (dcalc, 'm mark) boxed_gexpr)
(ctx : 'a)
(p : 'm program) : 'm program Bindlib.box =
Bindlib.box_apply

2
compiler/dcalc/optimizations.mli
View File

@ -20,5 +20,5 @@
open Shared_ast
open Ast
val optimize_expr : decl_ctx -> 'm expr -> 'm expr Bindlib.box
val optimize_expr : decl_ctx -> 'm expr -> (dcalc, 'm mark) boxed_gexpr
val optimize_program : 'm program -> 'm program

2
compiler/desugared/ast.ml
View File

@ -211,7 +211,7 @@ type program = { program_scopes : scope ScopeMap.t; program_ctx : decl_ctx }
let rec locations_used e : LocationSet.t =
match e with
| ELocation l, m -> LocationSet.singleton (l, Expr.mark_pos m)
| EAbs (binder, _), _ ->
| EAbs { binder; _ }, _ ->
let _, body = Bindlib.unmbind binder in
locations_used body
| e ->

67
compiler/desugared/desugared_to_scope.ml
View File

@ -72,20 +72,19 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
| States states -> Marked.same_mark_as (List.assoc state states) s_var))
m
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
| EStruct (s_name, fields) ->
Expr.estruct s_name (StructFieldMap.map (translate_expr ctx) fields) m
| EStructAccess (e1, f_name, s_name) ->
Expr.estructaccess (translate_expr ctx e1) f_name s_name m
| EEnumInj (e1, cons, e_name) ->
Expr.eenuminj (translate_expr ctx e1) cons e_name m
| EMatchS (e1, e_name, arms) ->
Expr.ematchs (translate_expr ctx e1) e_name
(EnumConstructorMap.map (translate_expr ctx) arms)
| EStruct { name; fields } ->
Expr.estruct name (StructFieldMap.map (translate_expr ctx) fields) m
| EStructAccess { e; field; name } ->
Expr.estructaccess (translate_expr ctx e) field name m
| EInj { e; cons; name } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { e; name; cases } ->
Expr.ematch (translate_expr ctx e) name
(EnumConstructorMap.map (translate_expr ctx) cases)
m
| EScopeCall (sc_name, fields) ->
Expr.escopecall sc_name
| EScopeCall { scope; args } ->
Expr.escopecall scope
(ScopeVarMap.fold
(fun v e fields' ->
(fun v e args' ->
let v' =
match ScopeVarMap.find v ctx.scope_var_mapping with
| WholeVar v' -> v'
@ -95,14 +94,14 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
v'
| States [] -> assert false
in
ScopeVarMap.add v' (translate_expr ctx e) fields')
fields ScopeVarMap.empty)
ScopeVarMap.add v' (translate_expr ctx e) args')
args ScopeVarMap.empty)
m
| ELit
(( LBool _ | LEmptyError | LInt _ | LRat _ | LMoney _ | LUnit | LDate _
| LDuration _ ) as l) ->
Expr.elit l m
| EAbs (binder, typs) ->
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let new_vars = Array.map (fun var -> Var.make (Bindlib.name_of var)) vars in
let ctx =
@ -111,19 +110,20 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
{ ctx with var_mapping = Var.Map.add var new_var ctx.var_mapping })
ctx (Array.to_list vars) (Array.to_list new_vars)
in
Expr.eabs (Expr.bind new_vars (translate_expr ctx body)) typs m
| EApp (e1, args) ->
Expr.eapp (translate_expr ctx e1) (List.map (translate_expr ctx) args) m
Expr.eabs (Expr.bind new_vars (translate_expr ctx body)) tys m
| EApp { f; args } ->
Expr.eapp (translate_expr ctx f) (List.map (translate_expr ctx) args) m
| EOp op -> Expr.eop op m
| EDefault (excepts, just, cons) ->
| EDefault { excepts; just; cons } ->
Expr.edefault
(List.map (translate_expr ctx) excepts)
(translate_expr ctx just) (translate_expr ctx cons) m
| EIfThenElse (e1, e2, e3) ->
Expr.eifthenelse (translate_expr ctx e1) (translate_expr ctx e2)
(translate_expr ctx e3) m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)
m
| EArray args -> Expr.earray (List.map (translate_expr ctx) args) m
| ErrorOnEmpty e1 -> Expr.eerroronempty (translate_expr ctx e1) m
| EErrorOnEmpty e1 -> Expr.eerroronempty (translate_expr ctx e1) m
(** {1 Rule tree construction} *)
@ -626,6 +626,8 @@ let translate_program (pgrm : Ast.program) : untyped Scopelang.Ast.program =
Scopelang. This involves creating a new Scopelang scope variable for every
state of a Desugared variable. *)
let ctx =
(* Todo: since we rename all scope vars at this point, it would be better to
have different types for Desugared.ScopeVar.t and Scopelang.ScopeVar.t *)
ScopeMap.fold
(fun _scope scope_decl ctx ->
ScopeVarMap.fold
@ -663,8 +665,25 @@ let translate_program (pgrm : Ast.program) : untyped Scopelang.Ast.program =
pgrm.Ast.program_scopes
{ scope_var_mapping = ScopeVarMap.empty; var_mapping = Var.Map.empty }
in
let ctx_scopes =
ScopeMap.map
(fun out_str ->
let out_struct_fields =
ScopeVarMap.fold
(fun var fld out_map ->
let var' =
match ScopeVarMap.find var ctx.scope_var_mapping with
| WholeVar v -> v
| States l -> snd (List.hd (List.rev l))
in
ScopeVarMap.add var' fld out_map)
out_str.out_struct_fields ScopeVarMap.empty
in
{ out_str with out_struct_fields })
pgrm.Ast.program_ctx.ctx_scopes
in
{
Scopelang.Ast.program_scopes =
ScopeMap.map (translate_scope ctx) pgrm.program_scopes;
Scopelang.Ast.program_ctx = pgrm.program_ctx;
program_ctx = { pgrm.program_ctx with ctx_scopes };
}

12
compiler/driver.ml
View File

@ -308,17 +308,7 @@ let driver source_file (options : Cli.options) : int =
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Shared_ast.Scope.format ~debug:options.debug prgm.decl_ctx)
( scope_uid,
Option.get
(Shared_ast.Scope.fold_left ~init:None
~f:(fun acc scope_def _ ->
if
Shared_ast.ScopeName.compare scope_def.scope_name
scope_uid
= 0
then Some scope_def.scope_body
else acc)
prgm.scopes) )
(scope_uid, Shared_ast.Program.get_scope_body prgm scope_uid)
else
let prgrm_lcalc_expr =
Shared_ast.Expr.unbox

4
compiler/dune
View File

@ -50,3 +50,7 @@
(documentation
(package catala)
(mld_files index))
(alias
(name catala)
(deps catala.exe))

23
compiler/lcalc/ast.ml
View File

@ -28,31 +28,32 @@ let option_enum : EnumName.t = EnumName.fresh ("eoption", Pos.no_pos)
let none_constr : EnumConstructor.t = EnumConstructor.fresh ("ENone", Pos.no_pos)
let some_constr : EnumConstructor.t = EnumConstructor.fresh ("ESome", Pos.no_pos)
let option_enum_config : (EnumConstructor.t * typ) list =
[none_constr, (TLit TUnit, Pos.no_pos); some_constr, (TAny, Pos.no_pos)]
let option_enum_config : typ EnumConstructorMap.t =
EnumConstructorMap.empty
|> EnumConstructorMap.add none_constr (TLit TUnit, Pos.no_pos)
|> EnumConstructorMap.add some_constr (TAny, Pos.no_pos)
(* FIXME: proper typing in all the constructors below *)
let make_none m =
let tunit = TLit TUnit, Expr.mark_pos m in
Expr.einj
(Expr.elit LUnit (Expr.with_ty m tunit))
0 option_enum
[TLit TUnit, Pos.no_pos; TAny, Pos.no_pos]
m
Expr.einj (Expr.elit LUnit (Expr.with_ty m tunit)) none_constr option_enum m
let make_some e =
let m = Marked.get_mark e in
Expr.einj e 1 option_enum
[TLit TUnit, Expr.mark_pos m; TAny, Expr.mark_pos m]
m
Expr.einj e some_constr option_enum m
(** [make_matchopt_with_abs_arms arg e_none e_some] build an expression
[match arg with |None -> e_none | Some -> e_some] and requires e_some and
e_none to be in the form [EAbs ...].*)
let make_matchopt_with_abs_arms arg e_none e_some =
let m = Marked.get_mark arg in
Expr.ematch arg [e_none; e_some] option_enum m
let cases =
EnumConstructorMap.empty
|> EnumConstructorMap.add none_constr e_none
|> EnumConstructorMap.add some_constr e_some
in
Expr.ematch arg option_enum cases m
(** [make_matchopt pos v tau arg e_none e_some] builds an expression
[match arg with | None () -> e_none | Some v -> e_some]. It binds v to

2
compiler/lcalc/ast.mli
View File

@ -32,7 +32,7 @@ type 'm program = 'm expr Shared_ast.program
val option_enum : EnumName.t
val none_constr : EnumConstructor.t
val some_constr : EnumConstructor.t
val option_enum_config : (EnumConstructor.t * typ) list
val option_enum_config : typ EnumConstructorMap.t
val make_none : 'm mark -> 'm expr boxed
val make_some : 'm expr boxed -> 'm expr boxed

158
compiler/lcalc/closure_conversion.ml
View File

@ -31,74 +31,56 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
let rec aux e =
let m = Marked.get_mark e in
match Marked.unmark e with
| EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _
| EArray _ | ELit _ | EAssert _ | EOp _ | EIfThenElse _ | ERaise _
| ECatch _ ->
Expr.map_gather ~acc:Var.Set.empty ~join:Var.Set.union ~f:aux e
| EVar v ->
( (Bindlib.box_var v, m),
if Var.Set.mem v ctx.globally_bound_vars then Var.Set.empty
else Var.Set.singleton v )
| ETuple (args, s) ->
let new_args, free_vars =
List.fold_left
(fun (new_args, free_vars) arg ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, Var.Set.union new_free_vars free_vars)
([], Var.Set.empty) args
in
Expr.etuple (List.rev new_args) s m, free_vars
| ETupleAccess (e1, n, s, typs) ->
let new_e1, free_vars = aux e1 in
Expr.etupleaccess new_e1 n s typs m, free_vars
| EInj (e1, n, e_name, typs) ->
let new_e1, free_vars = aux e1 in
Expr.einj new_e1 n e_name typs m, free_vars
| EMatch (e1, arms, e_name) ->
let new_e1, free_vars = aux e1 in
( (if Var.Set.mem v ctx.globally_bound_vars then Var.Set.empty
else Var.Set.singleton v),
(Bindlib.box_var v, m) )
| EMatch { e; cases; name } ->
let free_vars, new_e = aux e in
(* We do not close the clotures inside the arms of the match expression,
since they get a special treatment at compilation to Scalc. *)
let new_arms, free_vars =
List.fold_right
(fun arm (new_arms, free_vars) ->
match Marked.unmark arm with
| EAbs (binder, typs) ->
let free_vars, new_cases =
EnumConstructorMap.fold
(fun cons e1 (free_vars, new_cases) ->
match Marked.unmark e1 with
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let new_body, new_free_vars = aux body in
let new_free_vars, new_body = aux body in
let new_binder = Expr.bind vars new_body in
( Expr.eabs new_binder typs (Marked.get_mark arm) :: new_arms,
Var.Set.union free_vars new_free_vars )
( Var.Set.union free_vars new_free_vars,
EnumConstructorMap.add cons
(Expr.eabs new_binder tys (Marked.get_mark e1))
new_cases )
| _ -> failwith "should not happen")
arms ([], free_vars)
cases
(free_vars, EnumConstructorMap.empty)
in
Expr.ematch new_e1 new_arms e_name m, free_vars
| EArray args ->
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], Var.Set.empty)
in
Expr.earray new_args m, free_vars
| ELit l -> Expr.elit l m, Var.Set.empty
| EApp ((EAbs (binder, typs_abs), e1_pos), args) ->
free_vars, Expr.ematch new_e name new_cases m
| EApp { f = EAbs { binder; tys }, e1_pos; args } ->
(* let-binding, we should not close these *)
let vars, body = Bindlib.unmbind binder in
let new_body, free_vars = aux body in
let free_vars, new_body = aux body in
let new_binder = Expr.bind vars new_body in
let new_args, free_vars =
let free_vars, new_args =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], free_vars)
(fun arg (free_vars, new_args) ->
let new_free_vars, new_arg = aux arg in
Var.Set.union free_vars new_free_vars, new_arg :: new_args)
args (free_vars, [])
in
Expr.eapp (Expr.eabs new_binder typs_abs e1_pos) new_args m, free_vars
| EAbs (binder, typs) ->
free_vars, Expr.eapp (Expr.eabs new_binder tys e1_pos) new_args m
| EAbs { binder; tys } ->
(* λ x.t *)
let binder_mark = m in
let binder_pos = Expr.mark_pos binder_mark in
(* Converting the closure. *)
let vars, body = Bindlib.unmbind binder in
(* t *)
let new_body, body_vars = aux body in
let body_vars, new_body = aux body in
(* [[t]] *)
let extra_vars =
Var.Set.diff body_vars (Var.Set.of_list (Array.to_list vars))
@ -117,8 +99,8 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
(fun i _ ->
Expr.etupleaccess
(Expr.evar inner_c_var binder_mark)
(i + 1) None
(List.map (fun _ -> any_ty) extra_vars_list)
(i + 1)
(List.length extra_vars_list)
binder_mark)
extra_vars_list)
new_body
@ -128,10 +110,11 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
Expr.make_abs
(Array.concat [Array.make 1 inner_c_var; vars])
new_closure_body
((TAny, binder_pos) :: typs)
((TAny, binder_pos) :: tys)
(Expr.pos e)
in
( Expr.make_let_in code_var
( extra_vars,
Expr.make_let_in code_var
(TAny, Expr.pos e)
new_closure
(Expr.etuple
@ -139,40 +122,25 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
:: List.map
(fun extra_var -> Bindlib.box_var extra_var, binder_mark)
extra_vars_list)
None m)
(Expr.pos e),
extra_vars )
| EApp ((EOp op, pos_op), args) ->
m)
(Expr.pos e) )
| EApp { f = EOp _, _; _ } ->
(* This corresponds to an operator call, which we don't want to
transform*)
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], Var.Set.empty)
in
Expr.eapp (Expr.eop op pos_op) new_args m, free_vars
| EApp ((EVar v, v_pos), args) when Var.Set.mem v ctx.globally_bound_vars ->
Expr.map_gather ~acc:Var.Set.empty ~join:Var.Set.union ~f:aux e
| EApp { f = EVar v, _; _ } when Var.Set.mem v ctx.globally_bound_vars ->
(* This corresponds to a scope call, which we don't want to transform*)
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], Var.Set.empty)
in
Expr.eapp (Bindlib.box_var v, v_pos) new_args m, free_vars
| EApp (e1, args) ->
let new_e1, free_vars = aux e1 in
Expr.map_gather ~acc:Var.Set.empty ~join:Var.Set.union ~f:aux e
| EApp { f = e1; args } ->
let free_vars, new_e1 = aux e1 in
let env_var = Var.make "env" in
let code_var = Var.make "code" in
let new_args, free_vars =
let free_vars, new_args =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, Var.Set.union free_vars new_free_vars)
args ([], free_vars)
(fun arg (free_vars, new_args) ->
let new_free_vars, new_arg = aux arg in
Var.Set.union free_vars new_free_vars, new_arg :: new_args)
args (free_vars, [])
in
let call_expr =
let m1 = Marked.get_mark e1 in
@ -180,7 +148,8 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
(TAny, Expr.pos e)
(Expr.etupleaccess
(Bindlib.box_var env_var, m1)
0 None [ (*TODO: fill?*) ]
0
(List.length new_args + 1)
m)
(Expr.eapp
(Bindlib.box_var code_var, m1)
@ -188,25 +157,12 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
m)
(Expr.pos e)
in
( Expr.make_let_in env_var (TAny, Expr.pos e) new_e1 call_expr (Expr.pos e),
free_vars )
| EAssert e1 ->
let new_e1, free_vars = aux e1 in
Expr.eassert new_e1 m, free_vars
| EOp op -> Expr.eop op m, Var.Set.empty
| EIfThenElse (e1, e2, e3) ->
let new_e1, free_vars1 = aux e1 in
let new_e2, free_vars2 = aux e2 in
let new_e3, free_vars3 = aux e3 in
( Expr.eifthenelse new_e1 new_e2 new_e3 m,
Var.Set.union (Var.Set.union free_vars1 free_vars2) free_vars3 )
| ERaise except -> Expr.eraise except m, Var.Set.empty
| ECatch (e1, except, e2) ->
let new_e1, free_vars1 = aux e1 in
let new_e2, free_vars2 = aux e2 in
Expr.ecatch new_e1 except new_e2 m, Var.Set.union free_vars1 free_vars2
( free_vars,
Expr.make_let_in env_var
(TAny, Expr.pos e)
new_e1 call_expr (Expr.pos e) )
in
let e', _vars = aux e in
let _vars, e' = aux e in
e'
let closure_conversion (p : 'm program) : 'm program Bindlib.box =

61
compiler/lcalc/compile_with_exceptions.ml
View File

@ -54,39 +54,39 @@ let rec translate_default
exceptions
and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
| EVar v -> Expr.make_var (Var.Map.find v ctx) (Marked.get_mark e)
| ETuple (args, s) ->
Expr.etuple (List.map (translate_expr ctx) args) s (Marked.get_mark e)
| ETupleAccess (e1, i, s, ts) ->
Expr.etupleaccess (translate_expr ctx e1) i s ts (Marked.get_mark e)
| EInj (e1, i, en, ts) ->
Expr.einj (translate_expr ctx e1) i en ts (Marked.get_mark e)
| EMatch (e1, cases, en) ->
Expr.ematch (translate_expr ctx e1)
(List.map (translate_expr ctx) cases)
en (Marked.get_mark e)
| EArray es ->
Expr.earray (List.map (translate_expr ctx) es) (Marked.get_mark e)
| EVar v -> Expr.make_var (Var.Map.find v ctx) m
| EStruct { name; fields } ->
Expr.estruct name (StructFieldMap.map (translate_expr ctx) fields) m
| EStructAccess { name; e; field } ->
Expr.estructaccess (translate_expr ctx e) field name m
| EInj { name; e; cons } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { name; e; cases } ->
Expr.ematch (translate_expr ctx e) name
(EnumConstructorMap.map (translate_expr ctx) cases)
m
| EArray es -> Expr.earray (List.map (translate_expr ctx) es) m
| ELit
((LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _) as
l) ->
Expr.elit l (Marked.get_mark e)
| ELit LEmptyError -> Expr.eraise EmptyError (Marked.get_mark e)
| EOp op -> Expr.eop op (Marked.get_mark e)
| EIfThenElse (e1, e2, e3) ->
Expr.eifthenelse (translate_expr ctx e1) (translate_expr ctx e2)
(translate_expr ctx e3) (Marked.get_mark e)
| EAssert e1 -> Expr.eassert (translate_expr ctx e1) (Marked.get_mark e)
| ErrorOnEmpty arg ->
Expr.elit l m
| ELit LEmptyError -> Expr.eraise EmptyError m
| EOp op -> Expr.eop op m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)
m
| EAssert e1 -> Expr.eassert (translate_expr ctx e1) m
| EErrorOnEmpty arg ->
Expr.ecatch (translate_expr ctx arg) EmptyError
(Expr.eraise NoValueProvided (Marked.get_mark e))
(Marked.get_mark e)
| EApp (e1, args) ->
Expr.eapp (translate_expr ctx e1)
(Expr.eraise NoValueProvided m)
m
| EApp { f; args } ->
Expr.eapp (translate_expr ctx f)
(List.map (translate_expr ctx) args)
(Marked.get_mark e)
| EAbs (binder, ts) ->
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
Array.fold_right
@ -98,15 +98,16 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
let lc_vars = Array.of_list lc_vars in
let new_body = translate_expr ctx body in
let new_binder = Expr.bind lc_vars new_body in
Expr.eabs new_binder ts (Marked.get_mark e)
| EDefault ([exn], just, cons) when !Cli.optimize_flag ->
Expr.eabs new_binder tys (Marked.get_mark e)
| EDefault { excepts = [exn]; just; cons } when !Cli.optimize_flag ->
(* FIXME: bad place to rely on a global flag *)
Expr.ecatch (translate_expr ctx exn) EmptyError
(Expr.eifthenelse (translate_expr ctx just) (translate_expr ctx cons)
(Expr.eraise EmptyError (Marked.get_mark e))
(Marked.get_mark e))
(Marked.get_mark e)
| EDefault (exceptions, just, cons) ->
translate_default ctx exceptions just cons (Marked.get_mark e)
| EDefault { excepts; just; cons } ->
translate_default ctx excepts just cons (Marked.get_mark e)
let rec translate_scope_lets
(decl_ctx : decl_ctx)

87
compiler/lcalc/compile_without_exceptions.ml
View File

@ -170,7 +170,7 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
created a variable %a to replace it" Print.var v Print.var v'; *)
Expr.make_var v' mark, Var.Map.singleton v' e
else (find ~info:"should never happen" v ctx).expr, Var.Map.empty
| EApp ((EVar v, p), [(ELit LUnit, _)]) ->
| EApp { f = EVar v, p; args = [(ELit LUnit, _)] } ->
if not (find ~info:"search for a variable" v ctx).is_pure then
let v' = Var.make (Bindlib.name_of v) in
(* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a,
@ -179,7 +179,7 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
else
Errors.raise_spanned_error (Expr.pos e)
"Internal error: an pure variable was found in an unpure environment."
| EDefault (_exceptions, _just, _cons) ->
| EDefault _ ->
let v' = Var.make "default_term" in
Expr.make_var v' mark, Var.Map.singleton v' e
| ELit LEmptyError ->
@ -187,7 +187,7 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
Expr.make_var v' mark, Var.Map.singleton v' e
(* This one is a very special case. It transform an unpure expression
environement to a pure expression. *)
| ErrorOnEmpty arg ->
| EErrorOnEmpty arg ->
(* [ match arg with | None -> raise NoValueProvided | Some v -> {{ v }} ] *)
let silent_var = Var.make "_" in
let x = Var.make "non_empty_argument" in
@ -206,22 +206,23 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
((LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _) as
l) ->
Expr.elit l mark, Var.Map.empty
| EIfThenElse (e1, e2, e3) ->
let e1', h1 = translate_and_hoist ctx e1 in
let e2', h2 = translate_and_hoist ctx e2 in
let e3', h3 = translate_and_hoist ctx e3 in
| EIfThenElse { cond; etrue; efalse } ->
let cond', h1 = translate_and_hoist ctx cond in
let etrue', h2 = translate_and_hoist ctx etrue in
let efalse', h3 = translate_and_hoist ctx efalse in
let e' = Expr.eifthenelse e1' e2' e3' mark in
let e' = Expr.eifthenelse cond' etrue' efalse' mark in
(*(* equivalent code : *) let e' = let+ e1' = e1' and+ e2' = e2' and+ e3' =
e3' in (A.EIfThenElse (e1', e2', e3'), pos) in *)
(*(* equivalent code : *) let e' = let+ cond' = cond' and+ etrue' = etrue'
and+ efalse' = efalse' in (A.EIfThenElse (cond', etrue', efalse'), pos)
in *)
e', disjoint_union_maps (Expr.pos e) [h1; h2; h3]
| EAssert e1 ->
(* same behavior as in the ICFP paper: if e1 is empty, then no error is
raised. *)
let e1', h1 = translate_and_hoist ctx e1 in
Expr.eassert e1' mark, h1
| EAbs (binder, ts) ->
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
ArrayLabels.fold_right vars ~init:(ctx, []) ~f:(fun var (ctx, lc_vars) ->
@ -242,8 +243,8 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
let new_body, hoists = translate_and_hoist ctx body in
let new_binder = Expr.bind lc_vars new_body in
Expr.eabs new_binder (List.map translate_typ ts) mark, hoists
| EApp (e1, args) ->
Expr.eabs new_binder (List.map translate_typ tys) mark, hoists
| EApp { f = e1; args } ->
let e1', h1 = translate_and_hoist ctx e1 in
let args', h_args =
args |> List.map (translate_and_hoist ctx) |> List.split
@ -252,29 +253,36 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
let hoists = disjoint_union_maps (Expr.pos e) (h1 :: h_args) in
let e' = Expr.eapp e1' args' mark in
e', hoists
| ETuple (args, s) ->
let args', h_args =
args |> List.map (translate_and_hoist ctx) |> List.split
| EStruct { name; fields } ->
let fields', h_fields =
StructFieldMap.fold
(fun field e (fields, hoists) ->
let e, h = translate_and_hoist ctx e in
StructFieldMap.add field e fields, h :: hoists)
fields (StructFieldMap.empty, [])
in
let hoists = disjoint_union_maps (Expr.pos e) h_args in
Expr.etuple args' s mark, hoists
| ETupleAccess (e1, i, s, ts) ->
let hoists = disjoint_union_maps (Expr.pos e) h_fields in
Expr.estruct name fields' mark, hoists
| EStructAccess { name; e = e1; field } ->
let e1', hoists = translate_and_hoist ctx e1 in
let e1' = Expr.etupleaccess e1' i s ts mark in
let e1' = Expr.estructaccess e1' field name mark in
e1', hoists
| EInj (e1, i, en, ts) ->
| EInj { name; e = e1; cons } ->
let e1', hoists = translate_and_hoist ctx e1 in
let e1' = Expr.einj e1' i en ts mark in
let e1' = Expr.einj e1' cons name mark in
e1', hoists
| EMatch (e1, cases, en) ->
| EMatch { name; e = e1; cases } ->
let e1', h1 = translate_and_hoist ctx e1 in
let cases', h_cases =
cases |> List.map (translate_and_hoist ctx) |> List.split
EnumConstructorMap.fold
(fun cons e (cases, hoists) ->
let e', h = translate_and_hoist ctx e in
EnumConstructorMap.add cons e' cases, h :: hoists)
cases
(EnumConstructorMap.empty, [])
in
let hoists = disjoint_union_maps (Expr.pos e) (h1 :: h_cases) in
let e' = Expr.ematch e1' cases' en mark in
let e' = Expr.ematch e1' name cases' mark in
e', hoists
| EArray es ->
let es', hoists = es |> List.map (translate_and_hoist ctx) |> List.split in
@ -302,14 +310,14 @@ and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.expr) :
(* Here we have to handle only the cases appearing in hoists, as defined
the [translate_and_hoist] function. *)
| EVar v -> (find ~info:"should never happen" v ctx).expr
| EDefault (excep, just, cons) ->
let excep' = List.map (translate_expr ctx) excep in
| EDefault { excepts; just; cons } ->
let excepts' = List.map (translate_expr ctx) excepts in
let just' = translate_expr ctx just in
let cons' = translate_expr ctx cons in
(* calls handle_option. *)
Expr.make_app
(Expr.make_var (Var.translate A.handle_default_opt) mark_hoist)
[Expr.earray excep' mark_hoist; just'; cons']
[Expr.earray excepts' mark_hoist; just'; cons']
pos
| ELit LEmptyError -> A.make_none mark_hoist
| EAssert arg ->
@ -354,7 +362,7 @@ let rec translate_scope_let (ctx : 'm ctx) (lets : 'm D.expr scope_body_expr) :
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = typ;
scope_let_expr = EAbs (binder, _), emark;
scope_let_expr = EAbs { binder; _ }, emark;
scope_let_next = next;
scope_let_pos = pos;
} ->
@ -385,7 +393,7 @@ let rec translate_scope_let (ctx : 'm ctx) (lets : 'm D.expr scope_body_expr) :
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = typ;
scope_let_expr = (ErrorOnEmpty _, emark) as expr;
scope_let_expr = (EErrorOnEmpty _, emark) as expr;
scope_let_next = next;
scope_let_pos = pos;
} ->
@ -537,15 +545,14 @@ let translate_program (prgm : 'm D.program) : 'm A.program =
decl_ctx with
ctx_structs =
prgm.decl_ctx.ctx_structs
|> StructMap.mapi (fun n l ->
|> StructMap.mapi (fun n str ->
if List.mem n inputs_structs then
ListLabels.map l ~f:(fun (n, tau) ->
(* Cli.debug_print @@ Format.asprintf "Input type: %a"
(Print.typ decl_ctx) tau; Cli.debug_print @@
Format.asprintf "Output type: %a" (Print.typ decl_ctx)
(translate_typ tau); *)
n, translate_typ tau)
else l);
StructFieldMap.map translate_typ str
(* Cli.debug_print @@ Format.asprintf "Input type: %a"
(Print.typ decl_ctx) tau; Cli.debug_print @@ Format.asprintf
"Output type: %a" (Print.typ decl_ctx) (translate_typ
tau); *)
else str);
}
in

83
compiler/lcalc/optimizations.ml
View File

@ -18,45 +18,42 @@ open Shared_ast
open Ast
module D = Dcalc.Ast
let visitor_map (t : 'a -> 'm expr -> 'm expr boxed) (ctx : 'a) (e : 'm expr) :
'm expr boxed =
Expr.map ctx ~f:t e
let visitor_map (t : 'm expr -> 'm expr boxed) (e : 'm expr) : 'm expr boxed =
Expr.map ~f:t e
let rec iota_expr (_ : unit) (e : 'm expr) : 'm expr boxed =
let rec iota_expr (e : 'm expr) : 'm expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
| EMatch ((EInj (e1, i, n', _ts), _), cases, n) when EnumName.compare n n' = 0
->
let e1 = visitor_map iota_expr () e1 in
let case = visitor_map iota_expr () (List.nth cases i) in
| EMatch { e = EInj { e = e'; cons; name = n' }, _; cases; name = n }
when EnumName.equal n n' ->
let e1 = visitor_map iota_expr e' in
let case = visitor_map iota_expr (EnumConstructorMap.find cons cases) in
Expr.eapp case [e1] m
| EMatch (e', cases, n)
| EMatch { e = e'; cases; name = n }
when cases
|> List.mapi (fun i (case, _pos) ->
match case with
| EInj (_ei, i', n', _ts') ->
i = i' && (* n = n' *) EnumName.compare n n' = 0
|> EnumConstructorMap.mapi (fun i case ->
match Marked.unmark case with
| EInj { cons = i'; name = n'; _ } ->
EnumConstructor.equal i i' && EnumName.equal n n'
| _ -> false)
|> List.for_all Fun.id ->
visitor_map iota_expr () e'
| _ -> visitor_map iota_expr () e
|> EnumConstructorMap.for_all (fun _ b -> b) ->
visitor_map iota_expr e'
| _ -> visitor_map iota_expr e
let rec beta_expr (e : 'm expr) : 'm expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
| EApp (e1, args) ->
| EApp { f = e1; args } ->
Expr.Box.app1n (beta_expr e1) (List.map beta_expr args)
(fun e1 args ->
match Marked.unmark e1 with
| EAbs (binder, _) -> Marked.unmark (Expr.subst binder args)
| _ -> EApp (e1, args))
| EAbs { binder; _ } -> Marked.unmark (Expr.subst binder args)
| _ -> EApp { f = e1; args })
m
| _ -> visitor_map (fun () -> beta_expr) () e
| _ -> visitor_map beta_expr e
let iota_optimizations (p : 'm program) : 'm program =
let new_scopes =
Scope.map_exprs ~f:(iota_expr ()) ~varf:(fun v -> v) p.scopes
in
let new_scopes = Scope.map_exprs ~f:iota_expr ~varf:(fun v -> v) p.scopes in
{ p with scopes = Bindlib.unbox new_scopes }
(* TODO: beta optimizations apply inlining of the program. We left the inclusion
@ -70,30 +67,30 @@ let _beta_optimizations (p : 'm program) : 'm program =
let rec peephole_expr (e : 'm expr) : 'm expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
| EIfThenElse (e1, e2, e3) ->
Expr.Box.app3 (peephole_expr e1) (peephole_expr e2) (peephole_expr e3)
(fun e1 e2 e3 ->
match Marked.unmark e1 with
| EIfThenElse { cond; etrue; efalse } ->
Expr.Box.app3 (peephole_expr cond) (peephole_expr etrue)
(peephole_expr efalse)
(fun cond etrue efalse ->
match Marked.unmark cond with
| ELit (LBool true)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool true), _)]) ->
Marked.unmark e2
| EApp { f = EOp (Unop (Log _)), _; args = [(ELit (LBool true), _)] } ->
Marked.unmark etrue
| ELit (LBool false)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool false), _)]) ->
Marked.unmark e3
| _ -> EIfThenElse (e1, e2, e3))
| EApp { f = EOp (Unop (Log _)), _; args = [(ELit (LBool false), _)] }
->
Marked.unmark efalse
| _ -> EIfThenElse { cond; etrue; efalse })
m
| ECatch (e1, except, e2) ->
Expr.Box.app2 (peephole_expr e1) (peephole_expr e2)
(fun e1 e2 ->
match Marked.unmark e1, Marked.unmark e2 with
| ERaise except', ERaise except''
when except' = except && except = except'' ->
ERaise except
| ERaise except', _ when except' = except -> Marked.unmark e2
| _, ERaise except' when except' = except -> Marked.unmark e1
| _ -> ECatch (e1, except, e2))
| ECatch { body; exn; handler } ->
Expr.Box.app2 (peephole_expr body) (peephole_expr handler)
(fun body handler ->
match Marked.unmark body, Marked.unmark handler with
| ERaise exn', ERaise exn'' when exn' = exn && exn = exn'' -> ERaise exn
| ERaise exn', _ when exn' = exn -> Marked.unmark handler
| _, ERaise exn' when exn' = exn -> Marked.unmark body
| _ -> ECatch { body; exn; handler })
m
| _ -> visitor_map (fun () -> peephole_expr) () e
| _ -> visitor_map peephole_expr e
let peephole_optimizations (p : 'm program) : 'm program =
let new_scopes =

123
compiler/lcalc/to_ocaml.ml
View File

@ -20,8 +20,7 @@ open Ast
open String_common
module D = Dcalc.Ast
let find_struct (s : StructName.t) (ctx : decl_ctx) :
(StructFieldName.t * typ) list =
let find_struct (s : StructName.t) (ctx : decl_ctx) : typ StructFieldMap.t =
try StructMap.find s ctx.ctx_structs
with Not_found ->
let s_name, pos = StructName.get_info s in
@ -29,8 +28,7 @@ let find_struct (s : StructName.t) (ctx : decl_ctx) :
"Internal Error: Structure %s was not found in the current environment."
s_name
let find_enum (en : EnumName.t) (ctx : decl_ctx) :
(EnumConstructor.t * typ) list =
let find_enum (en : EnumName.t) (ctx : decl_ctx) : typ EnumConstructorMap.t =
try EnumMap.find en ctx.ctx_enums
with Not_found ->
let en_name, pos = EnumName.get_info en in
@ -243,7 +241,7 @@ let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit =
let needs_parens (e : 'm expr) : bool =
match Marked.unmark e with
| EApp ((EAbs (_, _), _), _)
| EApp { f = EAbs _, _; _ }
| ELit (LBool _ | LUnit)
| EVar _ | ETuple _ | EOp _ ->
false
@ -279,56 +277,51 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
in
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| ETuple (es, None) ->
| ETuple es ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
es
| ETuple (es, Some s) ->
if List.length es = 0 then Format.fprintf fmt "()"
| EStruct { name = s; fields = es } ->
if StructFieldMap.is_empty es then Format.fprintf fmt "()"
else
Format.fprintf fmt "{@[<hov 2>%a@]}"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt (e, struct_field) ->
(fun fmt (struct_field, e) ->
Format.fprintf fmt "@[<hov 2>%a =@ %a@]" format_struct_field_name
(Some s, struct_field) format_with_parens e))
(List.combine es (List.map fst (find_struct s ctx)))
(StructFieldMap.bindings es)
| EArray es ->
Format.fprintf fmt "@[<hov 2>[|%a|]@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
es
| ETupleAccess (e1, n, s, ts) -> (
match s with
| None ->
Format.fprintf fmt "let@ %a@ = %a@ in@ x"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt i -> Format.fprintf fmt "%s" (if i = n then "x" else "_")))
(List.mapi (fun i _ -> i) ts)
format_with_parens e1
| Some s ->
Format.fprintf fmt "%a.%a" format_with_parens e1 format_struct_field_name
(Some s, fst (List.nth (find_struct s ctx) n)))
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a.%a@ %a@]" format_to_module_name (`Ename en)
format_enum_cons_name
(fst (List.nth (find_enum en ctx) n))
format_with_parens e
| EMatch (e, es, e_name) ->
| ETupleAccess { e; index; size } ->
Format.fprintf fmt "let@ %a@ = %a@ in@ x"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt i -> Format.fprintf fmt "%s" (if i = index then "x" else "_")))
(List.init size Fun.id) format_with_parens e
| EStructAccess { e; field; name } ->
Format.fprintf fmt "%a.%a" format_with_parens e format_struct_field_name
(Some name, field)
| EInj { e; cons; name } ->
Format.fprintf fmt "@[<hov 2>%a.%a@ %a@]" format_to_module_name
(`Ename name) format_enum_cons_name cons format_with_parens e
| EMatch { e; cases; name } ->
Format.fprintf fmt "@[<hv>@[<hov 2>match@ %a@]@ with@\n| %a@]"
format_with_parens e
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ")
(fun fmt (e, c) ->
(fun fmt (c, e) ->
Format.fprintf fmt "@[<hov 2>%a.%a %a@]" format_to_module_name
(`Ename e_name) format_enum_cons_name c
(`Ename name) format_enum_cons_name c
(fun fmt e ->
match Marked.unmark e with
| EAbs (binder, _) ->
| EAbs { binder; _ } ->
let xs, body = Bindlib.unmbind binder in
Format.fprintf fmt "%a ->@ %a"
(Format.pp_print_list
@ -338,11 +331,11 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
| _ -> assert false
(* should not happen *))
e))
(List.combine es (List.map fst (find_enum e_name ctx)))
(EnumConstructorMap.bindings cases)
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.mark (Expr.pos e) l)
| EApp ((EAbs (binder, taus), _), args) ->
| EApp { f = EAbs { binder; tys }, _; args } ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) tys in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args in
Format.fprintf fmt "(%a%a)"
(Format.pp_print_list
@ -351,30 +344,34 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
Format.fprintf fmt "@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n"
format_var x format_typ tau format_with_parens arg))
xs_tau_arg format_with_parens body
| EAbs (binder, taus) ->
| EAbs { binder; tys } ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) tys in
Format.fprintf fmt "@[<hov 2>fun@ %a ->@ %a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (x, tau) ->
Format.fprintf fmt "@[<hov 2>(%a:@ %a)@]" format_var x format_typ tau))
xs_tau format_expr body
| EApp ((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2]) ->
| EApp { f = EOp (Binop ((Map | Filter) as op)), _; args = [arg1; arg2] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop (op, Pos.no_pos)
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
| EApp { f = EOp (Binop op), _; args = [arg1; arg2] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
format_binop (op, Pos.no_pos) format_with_parens arg2
| EApp ((EApp ((EOp (Unop (Log (BeginCall, info))), _), [f]), _), [arg])
| EApp
{
f = EApp { f = EOp (Unop (Log (BeginCall, info))), _; args = [f] }, _;
args = [arg];
}
when !Cli.trace_flag ->
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
format_with_parens f format_with_parens arg
| EApp ((EOp (Unop (Log (VarDef tau, info))), _), [arg1]) when !Cli.trace_flag
->
| EApp { f = EOp (Unop (Log (VarDef tau, info))), _; args = [arg1] }
when !Cli.trace_flag ->
Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" format_uid_list
info typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1
| EApp ((EOp (Unop (Log (PosRecordIfTrueBool, _))), m), [arg1])
| EApp { f = EOp (Unop (Log (PosRecordIfTrueBool, _))), m; args = [arg1] }
when !Cli.trace_flag ->
let pos = Expr.mark_pos m in
Format.fprintf fmt
@ -383,15 +380,16 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) format_with_parens arg1
| EApp ((EOp (Unop (Log (EndCall, info))), _), [arg1]) when !Cli.trace_flag ->
| EApp { f = EOp (Unop (Log (EndCall, info))), _; args = [arg1] }
when !Cli.trace_flag ->
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
format_with_parens arg1
| EApp ((EOp (Unop (Log _)), _), [arg1]) ->
| EApp { f = EOp (Unop (Log _)), _; args = [arg1] } ->
Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
| EApp { f = EOp (Unop op), _; args = [arg1] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos)
format_with_parens arg1
| EApp ((EVar x, pos), args)
| EApp { f = EVar x, pos; args }
when Var.compare x (Var.translate Ast.handle_default) = 0
|| Var.compare x (Var.translate Ast.handle_default_opt) = 0 ->
Format.fprintf fmt
@ -409,16 +407,16 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EApp (f, args) ->
| EApp { f; args } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EIfThenElse (e1, e2, e3) ->
| EIfThenElse { cond; etrue; efalse } ->
Format.fprintf fmt
"@[<hov 2> if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@]"
format_with_parens e1 format_with_parens e2 format_with_parens e3
format_with_parens cond format_with_parens etrue format_with_parens efalse
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
@ -437,18 +435,17 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(Pos.get_law_info (Expr.pos e'))
| ERaise exc ->
Format.fprintf fmt "raise@ %a" format_exception (exc, Expr.pos e)
| ECatch (e1, exc, e2) ->
| ECatch { body; exn; handler } ->
Format.fprintf fmt
"@,@[<hv>@[<hov 2>try@ %a@]@ with@]@ @[<hov 2>%a@ ->@ %a@]"
format_with_parens e1 format_exception
(exc, Expr.pos e)
format_with_parens e2
format_with_parens body format_exception
(exn, Expr.pos e)
format_with_parens handler
let format_struct_embedding
(fmt : Format.formatter)
((struct_name, struct_fields) :
StructName.t * (StructFieldName.t * typ) list) =
if List.length struct_fields = 0 then
((struct_name, struct_fields) : StructName.t * typ StructFieldMap.t) =
if StructFieldMap.is_empty struct_fields then
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_struct_name struct_name format_to_module_name (`Sname struct_name)
else
@ -465,12 +462,12 @@ let format_struct_embedding
struct_field typ_embedding_name struct_field_type
format_struct_field_name
(Some struct_name, struct_field)))
struct_fields
(StructFieldMap.bindings struct_fields)
let format_enum_embedding
(fmt : Format.formatter)
((enum_name, enum_cases) : EnumName.t * (EnumConstructor.t * typ) list) =
if List.length enum_cases = 0 then
((enum_name, enum_cases) : EnumName.t * typ EnumConstructorMap.t) =
if EnumConstructorMap.is_empty enum_cases then
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_to_module_name (`Ename enum_name) format_enum_name enum_name
else
@ -486,14 +483,14 @@ let format_enum_embedding
Format.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]"
format_enum_cons_name enum_cons EnumConstructor.format_t enum_cons
typ_embedding_name enum_cons_type))
enum_cases
(EnumConstructorMap.bindings enum_cases)
let format_ctx
(type_ordering : Scopelang.Dependency.TVertex.t list)
(fmt : Format.formatter)
(ctx : decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
if List.length struct_fields = 0 then
if StructFieldMap.is_empty struct_fields then
Format.fprintf fmt
"@[<v 2>module %a = struct@\n@[<hov 2>type t = unit@]@]@\nend@\n"
format_to_module_name (`Sname struct_name)
@ -508,7 +505,7 @@ let format_ctx
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
(None, struct_field) format_typ struct_field_type))
struct_fields;
(StructFieldMap.bindings struct_fields);
if !Cli.trace_flag then
format_struct_embedding fmt (struct_name, struct_fields)
in
@ -521,7 +518,7 @@ let format_ctx
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
enum_cons format_typ enum_cons_type))
enum_cons;
(EnumConstructorMap.bindings enum_cons);
if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons)
in
let is_in_type_ordering s =

13
compiler/lcalc/to_ocaml.mli
View File

@ -14,17 +14,16 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Shared_ast
open Ast
(** Formats a lambda calculus program into a valid OCaml program *)
val avoid_keywords : string -> string
val find_struct : StructName.t -> decl_ctx -> (StructFieldName.t * typ) list
val find_enum : EnumName.t -> decl_ctx -> (EnumConstructor.t * typ) list
val find_struct : StructName.t -> decl_ctx -> typ StructFieldMap.t
val find_enum : EnumName.t -> decl_ctx -> typ EnumConstructorMap.t
val typ_needs_parens : typ -> bool
val needs_parens : 'm expr -> bool
(* val needs_parens : 'm expr -> bool *)
val format_enum_name : Format.formatter -> EnumName.t -> unit
val format_enum_cons_name : Format.formatter -> EnumConstructor.t -> unit
val format_struct_name : Format.formatter -> StructName.t -> unit
@ -34,9 +33,9 @@ val format_struct_field_name :
val format_to_module_name :
Format.formatter -> [< `Ename of EnumName.t | `Sname of StructName.t ] -> unit
(* * val format_lit : Format.formatter -> lit Marked.pos -> unit * val
format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit *)
val format_lit : Format.formatter -> lit Marked.pos -> unit
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_var : Format.formatter -> 'm Var.t -> unit
val format_program :

22
compiler/plugins/api_web.ml
View File

@ -166,7 +166,7 @@ module To_jsoo = struct
format_struct_field_name_camel_case struct_field
format_typ_to_jsoo struct_field_type fmt_struct_name ()
format_struct_field_name (None, struct_field)))
struct_fields
(StructFieldMap.bindings struct_fields)
in
let fmt_of_jsoo fmt _ =
Format.fprintf fmt "%a"
@ -186,7 +186,7 @@ module To_jsoo = struct
format_struct_field_name (None, struct_field)
format_typ_of_jsoo struct_field_type fmt_struct_name ()
format_struct_field_name_camel_case struct_field))
struct_fields
(StructFieldMap.bindings struct_fields)
in
let fmt_conv_funs fmt _ =
Format.fprintf fmt
@ -203,7 +203,7 @@ module To_jsoo = struct
() fmt_struct_name () fmt_module_struct_name () fmt_of_jsoo ()
in
if List.length struct_fields = 0 then
if StructFieldMap.is_empty struct_fields then
Format.fprintf fmt
"class type %a =@ object end@\n\
let %a_to_jsoo (_ : %a.t) : %a Js.t = object%%js end@\n\
@ -220,11 +220,11 @@ module To_jsoo = struct
Format.fprintf fmt "@[<hov 2>method %a:@ %a %a@]"
format_struct_field_name_camel_case struct_field format_typ
struct_field_type format_prop_or_meth struct_field_type))
struct_fields fmt_conv_funs ()
(StructFieldMap.bindings struct_fields)
fmt_conv_funs ()
in
let format_enum_decl
fmt
(enum_name, (enum_cons : (EnumConstructor.t * typ) list)) =
let format_enum_decl fmt (enum_name, (enum_cons : typ EnumConstructorMap.t))
=
let fmt_enum_name fmt _ = format_enum_name fmt enum_name in
let fmt_module_enum_name fmt _ =
To_ocaml.format_to_module_name fmt (`Ename enum_name)
@ -247,7 +247,7 @@ module To_jsoo = struct
end@]"
format_enum_cons_name cname format_enum_cons_name cname
format_typ_to_jsoo typ))
enum_cons
(EnumConstructorMap.bindings enum_cons)
in
let fmt_of_jsoo fmt _ =
Format.fprintf fmt
@ -273,7 +273,8 @@ module To_jsoo = struct
format_enum_cons_name cname fmt_module_enum_name ()
format_enum_cons_name cname format_typ_of_jsoo typ
fmt_enum_name ()))
enum_cons fmt_module_enum_name ()
(EnumConstructorMap.bindings enum_cons)
fmt_module_enum_name ()
in
let fmt_conv_funs fmt _ =
@ -301,7 +302,8 @@ module To_jsoo = struct
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (enum_cons, _) ->
Format.fprintf fmt "- \"%a\"" format_enum_cons_name enum_cons))
enum_cons fmt_conv_funs ()
(EnumConstructorMap.bindings enum_cons)
fmt_conv_funs ()
in
let is_in_type_ordering s =
List.exists

10
compiler/plugins/json_schema.ml
View File

@ -97,7 +97,7 @@ module To_json = struct
(fun fmt (field_name, field_type) ->
Format.fprintf fmt "@[<hov 2>\"%a\": {@\n%a@]@\n}"
format_struct_field_name_camel_case field_name fmt_type field_type))
(find_struct sname ctx)
(StructFieldMap.bindings (find_struct sname ctx))
let fmt_definitions
(ctx : decl_ctx)
@ -118,11 +118,13 @@ module To_json = struct
(t :: acc) @ collect_required_type_defs_from_scope_input s
| TEnum e ->
List.fold_left collect (t :: acc)
(List.map snd (EnumMap.find e ctx.ctx_enums))
(List.map snd
(EnumConstructorMap.bindings (EnumMap.find e ctx.ctx_enums)))
| TArray t -> collect acc t
| _ -> acc
in
find_struct input_struct ctx
|> StructFieldMap.bindings
|> List.fold_left (fun acc (_, field_typ) -> collect acc field_typ) []
|> List.sort_uniq (fun t t' -> String.compare (get_name t) (get_name t'))
in
@ -146,7 +148,7 @@ module To_json = struct
Format.fprintf fmt
"@[<hov 2>{@\n\"type\": \"string\",@\n\"enum\": [\"%a\"]@]@\n}"
format_enum_cons_name enum_cons))
enum_def
(EnumConstructorMap.bindings enum_def)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (enum_cons, payload_type) ->
@ -168,7 +170,7 @@ module To_json = struct
}@]@\n\
}"
format_enum_cons_name enum_cons fmt_type payload_type))
enum_def
(EnumConstructorMap.bindings enum_def)
in
Format.fprintf fmt "@\n%a"

79
compiler/scalc/compile_from_lambda.ml
View File

@ -35,36 +35,37 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
| EVar v ->
let local_var =
try A.EVar (Var.Map.find v ctxt.var_dict)
with Not_found -> A.EFunc (Var.Map.find v ctxt.func_dict)
with Not_found -> (
try A.EFunc (Var.Map.find v ctxt.func_dict)
with Not_found ->
Errors.raise_spanned_error (Expr.pos expr)
"Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n"
Print.var_debug v
(Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun ppf (v, _) -> Print.var_debug ppf v))
(Var.Map.bindings ctxt.var_dict))
in
[], (local_var, Expr.pos expr)
| ETuple (args, Some s_name) ->
| EStruct { fields; name } ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
StructFieldMap.fold
(fun _ arg (args_stmts, new_args) ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) args
fields ([], [])
in
let new_args = List.rev new_args in
let args_stmts = List.rev args_stmts in
args_stmts, (A.EStruct (new_args, s_name), Expr.pos expr)
| ETuple (_, None) -> failwith "Non-struct tuples cannot be compiled to scalc"
| ETupleAccess (e1, num_field, Some s_name, _) ->
args_stmts, (A.EStruct (new_args, name), Expr.pos expr)
| ETuple _ -> failwith "Tuples cannot be compiled to scalc"
| EStructAccess { e = e1; field; name } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let field_name =
fst (List.nth (StructMap.find s_name ctxt.decl_ctx.ctx_structs) num_field)
in
e1_stmts, (A.EStructFieldAccess (new_e1, field_name, s_name), Expr.pos expr)
| ETupleAccess (_, _, None, _) ->
failwith "Non-struct tuples cannot be compiled to scalc"
| EInj (e1, num_cons, e_name, _) ->
e1_stmts, (A.EStructFieldAccess (new_e1, field, name), Expr.pos expr)
| ETupleAccess _ -> failwith "Non-struct tuples cannot be compiled to scalc"
| EInj { e = e1; cons; name } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let cons_name =
fst (List.nth (EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons)
in
e1_stmts, (A.EInj (new_e1, cons_name, e_name), Expr.pos expr)
| EApp (f, args) ->
e1_stmts, (A.EInj (new_e1, cons, name), Expr.pos expr)
| EApp { f; args } ->
let f_stmts, new_f = translate_expr ctxt f in
let args_stmts, new_args =
List.fold_left
@ -120,11 +121,11 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
(* Assertions are always encapsulated in a unit-typed let binding *)
let e_stmts, new_e = translate_expr ctxt e in
e_stmts @ [A.SAssert (Marked.unmark new_e), Expr.pos block_expr]
| EApp ((EAbs (binder, taus), binder_mark), args) ->
| EApp { f = EAbs { binder; tys }, binder_mark; args } ->
(* This defines multiple local variables at the time *)
let binder_pos = Expr.mark_pos binder_mark in
let vars, body = Bindlib.unmbind binder in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) tys in
let ctxt =
{
ctxt with
@ -167,10 +168,10 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
in
let rest_of_block = translate_statements ctxt body in
local_decls @ List.flatten def_blocks @ rest_of_block
| EAbs (binder, taus) ->
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let binder_pos = Expr.pos block_expr in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) tys in
let closure_name =
match ctxt.inside_definition_of with
| None -> A.LocalName.fresh (ctxt.context_name, Expr.pos block_expr)
@ -203,13 +204,13 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
} ),
binder_pos );
]
| EMatch (e1, args, e_name) ->
| EMatch { e = e1; cases; name } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let new_args =
List.fold_left
(fun new_args arg ->
let new_cases =
EnumConstructorMap.fold
(fun _ arg new_args ->
match Marked.unmark arg with
| EAbs (binder, _) ->
| EAbs { binder; _ } ->
let vars, body = Bindlib.unmbind binder in
assert (Array.length vars = 1);
let var = vars.(0) in
@ -223,20 +224,20 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
(new_arg, scalc_var) :: new_args
| _ -> assert false
(* should not happen *))
[] args
cases []
in
let new_args = List.rev new_args in
e1_stmts @ [A.SSwitch (new_e1, e_name, new_args), Expr.pos block_expr]
| EIfThenElse (cond, e_true, e_false) ->
let new_args = List.rev new_cases in
e1_stmts @ [A.SSwitch (new_e1, name, new_args), Expr.pos block_expr]
| EIfThenElse { cond; etrue; efalse } ->
let cond_stmts, s_cond = translate_expr ctxt cond in
let s_e_true = translate_statements ctxt e_true in
let s_e_false = translate_statements ctxt e_false in
let s_e_true = translate_statements ctxt etrue in
let s_e_false = translate_statements ctxt efalse in
cond_stmts
@ [A.SIfThenElse (s_cond, s_e_true, s_e_false), Expr.pos block_expr]
| ECatch (e_try, except, e_catch) ->
let s_e_try = translate_statements ctxt e_try in
let s_e_catch = translate_statements ctxt e_catch in
[A.STryExcept (s_e_try, except, s_e_catch), Expr.pos block_expr]
| ECatch { body; exn; handler } ->
let s_e_try = translate_statements ctxt body in
let s_e_catch = translate_statements ctxt handler in
[A.STryExcept (s_e_try, exn, s_e_catch), Expr.pos block_expr]
| ERaise except ->
(* Before raising the exception, we still give a dummy definition to the
current variable so that tools like mypy don't complain. *)

41
compiler/scalc/print.ml
View File

@ -44,11 +44,12 @@ let rec format_expr
Print.punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
(fun fmt (e, (struct_field, _)) ->
Format.fprintf fmt "%a%a%a%a %a" Print.punctuation "\""
StructFieldName.format_t struct_field Print.punctuation "\""
Print.punctuation ":" format_expr e))
(List.combine es (List.map fst (StructMap.find s decl_ctx.ctx_structs)))
(List.combine es
(StructFieldMap.bindings (StructMap.find s decl_ctx.ctx_structs)))
Print.punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Print.punctuation "["
@ -56,20 +57,12 @@ let rec format_expr
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es Print.punctuation "]"
| EStructFieldAccess (e1, field, s) ->
| EStructFieldAccess (e1, field, _) ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 Print.punctuation "."
Print.punctuation "\"" StructFieldName.format_t
(fst
(List.find
(fun (field', _) -> StructFieldName.compare field' field = 0)
(StructMap.find s decl_ctx.ctx_structs)))
Print.punctuation "\""
| EInj (e, case, enum) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Print.enum_constructor
(fst
(List.find
(fun (case', _) -> EnumConstructor.compare case' case = 0)
(EnumMap.find enum decl_ctx.ctx_enums)))
Print.punctuation "\"" StructFieldName.format_t field Print.punctuation
"\""
| EInj (e, cons, _) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Print.enum_constructor cons
format_expr e
| ELit l -> Print.lit fmt l
| EApp ((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2]) ->
@ -101,22 +94,22 @@ let rec format_statement
match Marked.unmark stmt with
| SInnerFuncDef (name, func) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]" Print.keyword
"let" LocalName.format_t (Marked.unmark name)
"let" format_local_name (Marked.unmark name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
Format.fprintf fmt "%a%a %a@ %a%a" Print.punctuation "("
LocalName.format_t name Print.punctuation ":" (Print.typ decl_ctx)
format_local_name name Print.punctuation ":" (Print.typ decl_ctx)
typ Print.punctuation ")"))
func.func_params Print.punctuation "="
(format_block decl_ctx ~debug)
func.func_body
| SLocalDecl (name, typ) ->
Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" Print.keyword "decl"
LocalName.format_t (Marked.unmark name) Print.punctuation ":"
format_local_name (Marked.unmark name) Print.punctuation ":"
(Print.typ decl_ctx) typ
| SLocalDef (name, naked_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" LocalName.format_t
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_local_name
(Marked.unmark name) Print.punctuation "="
(format_expr decl_ctx ~debug)
naked_expr
@ -156,10 +149,12 @@ let rec format_statement
(fun fmt ((case, _), (arm_block, payload_name)) ->
Format.fprintf fmt "%a %a%a@ %a @[<v 2>%a@ %a@]" Print.punctuation
"|" Print.enum_constructor case Print.punctuation ":"
LocalName.format_t payload_name Print.punctuation "→"
format_local_name payload_name Print.punctuation "→"
(format_block decl_ctx ~debug)
arm_block))
(List.combine (EnumMap.find enum decl_ctx.ctx_enums) arms)
(List.combine
(EnumConstructorMap.bindings (EnumMap.find enum decl_ctx.ctx_enums))
arms)
and format_block
(decl_ctx : decl_ctx)
@ -183,8 +178,8 @@ let format_scope
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
Format.fprintf fmt "%a%a %a@ %a%a" Print.punctuation "("
LocalName.format_t name Print.punctuation ":" (Print.typ decl_ctx)
typ Print.punctuation ")"))
format_local_name name Print.punctuation ":" (Print.typ decl_ctx) typ
Print.punctuation ")"))
body.scope_body_func.func_params Print.punctuation "="
(format_block decl_ctx ~debug)
body.scope_body_func.func_body

41
compiler/scalc/to_python.ml
View File

@ -268,10 +268,11 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
Format.fprintf fmt "%a(%a)" format_struct_name s
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
(fun fmt (e, (struct_field, _)) ->
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
(format_expression ctx) e))
(List.combine es (List.map fst (StructMap.find s ctx.ctx_structs)))
(List.combine es
(StructFieldMap.bindings (StructMap.find s ctx.ctx_structs)))
| EStructFieldAccess (e1, field, _) ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
format_struct_field_name field
@ -400,7 +401,7 @@ let rec format_statement
List.map2
(fun (x, y) (cons, _) -> x, y, cons)
cases
(EnumMap.find e_name ctx.ctx_enums)
(EnumConstructorMap.bindings (EnumMap.find e_name ctx.ctx_enums))
in
let tmp_var = LocalName.fresh ("match_arg", Pos.no_pos) in
Format.fprintf fmt "%a = %a@\n@[<hov 4>if %a@]" format_var tmp_var
@ -442,6 +443,7 @@ let format_ctx
(fmt : Format.formatter)
(ctx : decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
let fields = StructFieldMap.bindings struct_fields in
Format.fprintf fmt
"class %a:@\n\
\ def __init__(self, %a) -> None:@\n\
@ -461,40 +463,41 @@ let format_ctx
struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun _fmt (struct_field, struct_field_type) ->
(fun fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "%a: %a" format_struct_field_name struct_field
format_typ struct_field_type))
struct_fields
(if List.length struct_fields = 0 then fun fmt _ ->
fields
(if StructFieldMap.is_empty struct_fields then fun fmt _ ->
Format.fprintf fmt " pass"
else
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (struct_field, _) ->
(fun fmt (struct_field, _) ->
Format.fprintf fmt " self.%a = %a" format_struct_field_name
struct_field format_struct_field_name struct_field))
struct_fields format_struct_name struct_name
(if List.length struct_fields > 0 then
fields format_struct_name struct_name
(if not (StructFieldMap.is_empty struct_fields) then
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " and@ ")
(fun _fmt (struct_field, _) ->
(fun fmt (struct_field, _) ->
Format.fprintf fmt "self.%a == other.%a" format_struct_field_name
struct_field format_struct_field_name struct_field)
else fun fmt _ -> Format.fprintf fmt "True")
struct_fields format_struct_name struct_name
fields format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
(fun _fmt (struct_field, _) ->
(fun fmt (struct_field, _) ->
Format.fprintf fmt "%a={}" format_struct_field_name struct_field))
struct_fields
fields
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun _fmt (struct_field, _) ->
(fun fmt (struct_field, _) ->
Format.fprintf fmt "self.%a" format_struct_field_name struct_field))
struct_fields
fields
in
let format_enum_decl fmt (enum_name, enum_cons) =
if List.length enum_cons = 0 then failwith "no constructors in the enum"
if EnumConstructorMap.is_empty enum_cons then
failwith "no constructors in the enum"
else
Format.fprintf fmt
"@[<hov 4>class %a_Code(Enum):@\n\
@ -522,9 +525,11 @@ let format_ctx
format_enum_name enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (i, enum_cons, enum_cons_type) ->
(fun fmt (i, enum_cons, enum_cons_type) ->
Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i))
(List.mapi (fun i (x, y) -> i, x, y) enum_cons)
(List.mapi
(fun i (x, y) -> i, x, y)
(EnumConstructorMap.bindings enum_cons))
format_enum_name enum_name format_enum_name enum_name format_enum_name
enum_name
in

2
compiler/scopelang/ast.ml
View File

@ -31,7 +31,7 @@ type 'm expr = (scopelang, 'm mark) gexpr
let rec locations_used (e : 'm expr) : LocationSet.t =
match e with
| ELocation l, pos -> LocationSet.singleton (l, Expr.mark_pos pos)
| EAbs (binder, _), _ ->
| EAbs { binder; _ }, _ ->
let _, body = Bindlib.unmbind binder in
locations_used body
| e ->

16
compiler/scopelang/dependency.ml
View File

@ -45,9 +45,9 @@ let rec expr_used_scopes e =
e ScopeMap.empty
in
match e with
| (EScopeCall (scope, _), m) as e ->
| (EScopeCall { scope; _ }, m) as e ->
ScopeMap.add scope (Expr.mark_pos m) (recurse_subterms e)
| EAbs (binder, _), _ ->
| EAbs { binder; _ }, _ ->
let _, body = Bindlib.unmbind binder in
expr_used_scopes body
| e -> recurse_subterms e
@ -192,8 +192,8 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
let g =
StructMap.fold
(fun s fields g ->
List.fold_left
(fun g (_, typ) ->
StructFieldMap.fold
(fun _ typ g ->
let def = TVertex.Struct s in
let g = TDependencies.add_vertex g def in
let used = get_structs_or_enums_in_type typ in
@ -210,14 +210,14 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
in
TDependencies.add_edge_e g edge)
used g)
g fields)
fields g)
structs g
in
let g =
EnumMap.fold
(fun e cases g ->
List.fold_left
(fun g (_, typ) ->
EnumConstructorMap.fold
(fun _ typ g ->
let def = TVertex.Enum e in
let g = TDependencies.add_vertex g def in
let used = get_structs_or_enums_in_type typ in
@ -234,7 +234,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
in
TDependencies.add_edge_e g edge)
used g)
g cases)
cases g)
enums g
in
g

9
compiler/scopelang/print.ml
View File

@ -22,7 +22,7 @@ let struc
ctx
(fmt : Format.formatter)
(name : StructName.t)
(fields : (StructFieldName.t * typ) list) : unit =
(fields : typ StructFieldMap.t) : unit =
Format.fprintf fmt "%a %a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword "struct"
StructName.format_t name Print.punctuation "=" Print.punctuation "{"
(Format.pp_print_list
@ -30,13 +30,14 @@ let struc
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a%a %a" StructFieldName.format_t field_name
Print.punctuation ":" (Print.typ ctx) typ))
fields Print.punctuation "}"
(StructFieldMap.bindings fields)
Print.punctuation "}"
let enum
ctx
(fmt : Format.formatter)
(name : EnumName.t)
(cases : (EnumConstructor.t * typ) list) : unit =
(cases : typ EnumConstructorMap.t) : unit =
Format.fprintf fmt "%a %a %a @\n@[<hov 2> %a@]" Print.keyword "enum"
EnumName.format_t name Print.punctuation "="
(Format.pp_print_list
@ -45,7 +46,7 @@ let enum
Format.fprintf fmt "%a %a%a %a" Print.punctuation "|"
EnumConstructor.format_t field_name Print.punctuation ":"
(Print.typ ctx) typ))
cases
(EnumConstructorMap.bindings cases)
let scope ?(debug = false) ctx fmt (name, decl) =
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"

322
compiler/scopelang/scope_to_dcalc.ml
View File

@ -34,6 +34,10 @@ type 'm scope_sig_ctx = {
scope_sig_in_fields :
(StructFieldName.t * Ast.io_input Marked.pos) ScopeVarMap.t;
(** Mapping between the input scope variables and the input struct fields. *)
scope_sig_out_fields : StructFieldName.t ScopeVarMap.t;
(** Mapping between the output scope variables and the output struct
fields. TODO: could likely be removed now that we have it in the
program ctx *)
}
type 'm scope_sigs_ctx = 'm scope_sig_ctx ScopeMap.t
@ -118,7 +122,7 @@ let collapse_similar_outcomes (type m) (excepts : m Ast.expr list) :
let cons_map =
List.fold_left
(fun map -> function
| (EDefault ([], _, cons), _) as e ->
| (EDefault { excepts = []; cons; _ }, _) as e ->
ExprMap.update cons
(fun prev -> Some (e :: Option.value ~default:[] prev))
map
@ -129,12 +133,12 @@ let collapse_similar_outcomes (type m) (excepts : m Ast.expr list) :
List.fold_right
(fun e (cons_map, excepts) ->
match e with
| EDefault ([], _, cons), _ ->
| EDefault { excepts = []; cons; _ }, _ ->
let collapsed_exc =
List.fold_left
(fun acc -> function
| EDefault ([], just, cons), pos ->
[EDefault (acc, just, cons), pos]
| EDefault { excepts = []; just; cons }, pos ->
[EDefault { excepts = acc; just; cons }, pos]
| _ -> assert false)
[]
(ExprMap.find cons cons_map)
@ -165,83 +169,47 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
(( LBool _ | LEmptyError | LInt _ | LRat _ | LMoney _ | LUnit | LDate _
| LDuration _ ) as l) ->
Expr.elit l m
| EStruct (struct_name, e_fields) ->
let struct_sig = StructMap.find struct_name ctx.structs in
let d_fields, remaining_e_fields =
List.fold_right
(fun (field_name, _) (d_fields, e_fields) ->
let field_e = StructFieldMap.find field_name e_fields in
let field_d = translate_expr ctx field_e in
field_d :: d_fields, StructFieldMap.remove field_name e_fields)
struct_sig ([], e_fields)
in
if StructFieldMap.cardinal remaining_e_fields > 0 then
Errors.raise_spanned_error (Expr.pos e)
"The fields \"%a\" do not belong to the structure %a"
StructName.format_t struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (field_name, _) ->
Format.fprintf fmt "%a" StructFieldName.format_t field_name))
(StructFieldMap.bindings remaining_e_fields)
else Expr.etuple d_fields (Some struct_name) m
| EStructAccess (e1, field_name, struct_name) ->
let struct_sig = StructMap.find struct_name ctx.structs in
let _, field_index =
try
List.assoc field_name (List.mapi (fun i (x, y) -> x, (y, i)) struct_sig)
with Not_found ->
Errors.raise_spanned_error (Expr.pos e)
"The field \"%a\" does not belong to the structure %a"
StructFieldName.format_t field_name StructName.format_t struct_name
in
let e1 = translate_expr ctx e1 in
Expr.etupleaccess e1 field_index (Some struct_name)
(List.map snd struct_sig) m
| EEnumInj (e1, constructor, enum_name) ->
let enum_sig = EnumMap.find enum_name ctx.enums in
let _, constructor_index =
try
List.assoc constructor (List.mapi (fun i (x, y) -> x, (y, i)) enum_sig)
with Not_found ->
Errors.raise_spanned_error (Expr.pos e)
"The constructor \"%a\" does not belong to the enum %a"
EnumConstructor.format_t constructor EnumName.format_t enum_name
in
let e1 = translate_expr ctx e1 in
Expr.einj e1 constructor_index enum_name (List.map snd enum_sig) m
| EMatchS (e1, enum_name, cases) ->
let enum_sig = EnumMap.find enum_name ctx.enums in
| EStruct { name; fields } ->
let fields = StructFieldMap.map (translate_expr ctx) fields in
Expr.estruct name fields m
| EStructAccess { e; field; name } ->
Expr.estructaccess (translate_expr ctx e) field name m
| EInj { e; cons; name } ->
let e' = translate_expr ctx e in
Expr.einj e' cons name m
| EMatch { e = e1; name; cases = e_cases } ->
let enum_sig = EnumMap.find name ctx.enums in
let d_cases, remaining_e_cases =
List.fold_right
(fun (constructor, _) (d_cases, e_cases) ->
(* FIXME: these checks should probably be moved to a better place *)
EnumConstructorMap.fold
(fun constructor _ (d_cases, e_cases) ->
let case_e =
try EnumConstructorMap.find constructor e_cases
with Not_found ->
Errors.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a is missing from this pattern \
matching"
EnumConstructor.format_t constructor EnumName.format_t enum_name
EnumConstructor.format_t constructor EnumName.format_t name
in
let case_d = translate_expr ctx case_e in
case_d :: d_cases, EnumConstructorMap.remove constructor e_cases)
enum_sig ([], cases)
( EnumConstructorMap.add constructor case_d d_cases,
EnumConstructorMap.remove constructor e_cases ))
enum_sig
(EnumConstructorMap.empty, e_cases)
in
if EnumConstructorMap.cardinal remaining_e_cases > 0 then
if not (EnumConstructorMap.is_empty remaining_e_cases) then
Errors.raise_spanned_error (Expr.pos e)
"Pattern matching is incomplete for enum %a: missing cases %a"
EnumName.format_t enum_name
EnumName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (case_name, _) ->
Format.fprintf fmt "%a" EnumConstructor.format_t case_name))
(EnumConstructorMap.bindings remaining_e_cases)
else
let e1 = translate_expr ctx e1 in
Expr.ematch e1 d_cases enum_name m
| EScopeCall (sc_name, fields) ->
(fun fmt (case_name, _) -> EnumConstructor.format_t fmt case_name))
(EnumConstructorMap.bindings remaining_e_cases);
let e1 = translate_expr ctx e1 in
Expr.ematch e1 name d_cases m
| EScopeCall { scope; args } ->
let pos = Expr.mark_pos m in
let sc_sig = ScopeMap.find sc_name ctx.scopes_parameters in
let sc_sig = ScopeMap.find scope ctx.scopes_parameters in
let in_var_map =
ScopeVarMap.merge
(fun var_name str_field expr ->
@ -269,11 +237,11 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
[
None, pos;
( Some "Declaration of scope '%a'",
Marked.get_mark (ScopeName.get_info sc_name) );
Marked.get_mark (ScopeName.get_info scope) );
]
"Unknown input variable '%a' in scope call of '%a'"
ScopeVar.format_t var_name ScopeName.format_t sc_name)
sc_sig.scope_sig_in_fields fields
ScopeVar.format_t var_name ScopeName.format_t scope)
sc_sig.scope_sig_in_fields args
in
let field_map =
ScopeVarMap.fold
@ -281,15 +249,15 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
in_var_map StructFieldMap.empty
in
let arg_struct =
Expr.make_struct field_map sc_sig.scope_sig_input_struct (mark_tany m pos)
Expr.estruct sc_sig.scope_sig_input_struct field_map (mark_tany m pos)
in
Expr.eapp
(Expr.evar sc_sig.scope_sig_scope_var (mark_tany m pos))
[arg_struct] m
| EApp (e1, args) ->
| EApp { f; args } ->
(* We insert various log calls to record arguments and outputs of
user-defined functions belonging to scopes *)
let e1_func = translate_expr ctx e1 in
let e1_func = translate_expr ctx f in
let markings l =
match l with
| ScopelangScopeVar (v, _) ->
@ -298,7 +266,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
[ScopeName.get_info s; ScopeVar.get_info v]
in
let e1_func =
match Marked.unmark e1 with
match Marked.unmark f with
| ELocation l -> tag_with_log_entry e1_func BeginCall (markings l)
| _ -> e1_func
in
@ -315,7 +283,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
Marked.unmark marked_input_typ, Marked.unmark marked_output_typ
| _ -> TAny, TAny
in
match Marked.unmark e1 with
match Marked.unmark f with
| ELocation (ScopelangScopeVar var) ->
retrieve_in_and_out_typ_or_any var ctx.scope_vars
| ELocation (SubScopeVar (_, sname, var)) ->
@ -325,7 +293,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
| _ -> TAny, TAny
in
let new_args =
match Marked.unmark e1, new_args with
match Marked.unmark f, new_args with
| ELocation l, [new_arg] ->
[
tag_with_log_entry new_arg (VarDef input_typ)
@ -335,7 +303,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
in
let new_e = Expr.eapp e1_func new_args m in
let new_e =
match Marked.unmark e1 with
match Marked.unmark f with
| ELocation l ->
tag_with_log_entry
(tag_with_log_entry new_e (VarDef output_typ)
@ -344,7 +312,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
| _ -> new_e
in
new_e
| EAbs (binder, typ) ->
| EAbs { binder; tys } ->
let xs, body = Bindlib.unmbind binder in
let new_xs = Array.map (fun x -> Var.make (Bindlib.name_of x)) xs in
let both_xs = Array.map2 (fun x new_x -> x, new_x) xs new_xs in
@ -360,8 +328,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
body
in
let binder = Expr.bind new_xs body in
Expr.eabs binder typ m
| EDefault (excepts, just, cons) ->
Expr.eabs binder tys m
| EDefault { excepts; just; cons } ->
let excepts = collapse_similar_outcomes excepts in
Expr.edefault
(List.map (translate_expr ctx) excepts)
@ -389,11 +357,12 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
%a's results. Maybe you forgot to qualify it as an output?"
SubScopeName.format_t (Marked.unmark s) ScopeVar.format_t
(Marked.unmark a) SubScopeName.format_t (Marked.unmark s))
| EIfThenElse (cond, et, ef) ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx et)
(translate_expr ctx ef) m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)
m
| EOp op -> Expr.eop op m
| ErrorOnEmpty e' -> Expr.eerroronempty (translate_expr ctx e') m
| EErrorOnEmpty e' -> Expr.eerroronempty (translate_expr ctx e') m
| EArray es -> Expr.earray (List.map (translate_expr ctx) es) m
(** The result of a rule translation is a list of assignment, with variables and
@ -531,25 +500,31 @@ let translate_rule
in
let pos_call = Marked.get_mark (SubScopeName.get_info subindex) in
let subscope_args =
List.map
(fun (subvar : scope_var_ctx) ->
if subscope_var_not_yet_defined subvar.scope_var_name then
(* This is a redundant check. Normally, all subscope variables
should have been defined (even an empty definition, if they're
not defined by any rule in the source code) by the translation
from desugared to the scope language. *)
Expr.empty_thunked_term m
else
let a_var, _, _ =
ScopeVarMap.find subvar.scope_var_name subscope_vars_defined
in
Expr.make_var a_var (mark_tany m pos_call))
all_subscope_input_vars
List.fold_left
(fun acc (subvar : scope_var_ctx) ->
let e =
if subscope_var_not_yet_defined subvar.scope_var_name then
(* This is a redundant check. Normally, all subscope variables
should have been defined (even an empty definition, if they're
not defined by any rule in the source code) by the translation
from desugared to the scope language. *)
Expr.empty_thunked_term m
else
let a_var, _, _ =
ScopeVarMap.find subvar.scope_var_name subscope_vars_defined
in
Expr.make_var a_var (mark_tany m pos_call)
in
let field =
Marked.unmark
(ScopeVarMap.find subvar.scope_var_name
subscope_sig.scope_sig_in_fields)
in
StructFieldMap.add field e acc)
StructFieldMap.empty all_subscope_input_vars
in
let subscope_struct_arg =
(* FIXME: this is very fragile: we assume that the ordering of the scope
variables is the same as the ordering of the struct fields. *)
Expr.etuple subscope_args (Some called_scope_input_struct)
Expr.estruct called_scope_input_struct subscope_args
(mark_tany m pos_call)
in
let all_subscope_output_vars_dcalc =
@ -602,34 +577,30 @@ let translate_rule
in
let result_bindings_lets next =
List.fold_right
(fun (var_ctx, v) (next, i) ->
( Bindlib.box_apply2
(fun next r ->
ScopeLet
{
scope_let_next = next;
scope_let_pos = pos_sigma;
scope_let_typ = var_ctx.scope_var_typ, pos_sigma;
scope_let_kind = DestructuringSubScopeResults;
scope_let_expr =
( ETupleAccess
( r,
i,
Some called_scope_return_struct,
List.map
(fun (var_ctx, _) ->
var_ctx.scope_var_typ, pos_sigma)
all_subscope_output_vars_dcalc ),
mark_tany m pos_sigma );
})
(Bindlib.bind_var v next)
(Expr.Box.lift
(Expr.make_var result_tuple_var (mark_tany m pos_sigma))),
i - 1 ))
all_subscope_output_vars_dcalc
(next, List.length all_subscope_output_vars_dcalc - 1)
(fun (var_ctx, v) next ->
let field =
ScopeVarMap.find var_ctx.scope_var_name
subscope_sig.scope_sig_out_fields
in
Bindlib.box_apply2
(fun next r ->
ScopeLet
{
scope_let_next = next;
scope_let_pos = pos_sigma;
scope_let_typ = var_ctx.scope_var_typ, pos_sigma;
scope_let_kind = DestructuringSubScopeResults;
scope_let_expr =
( EStructAccess
{ name = called_scope_return_struct; e = r; field },
mark_tany m pos_sigma );
})
(Bindlib.bind_var v next)
(Expr.Box.lift
(Expr.make_var result_tuple_var (mark_tany m pos_sigma))))
all_subscope_output_vars_dcalc next
in
( (fun next -> call_scope_let (fst (result_bindings_lets next))),
( (fun next -> call_scope_let (result_bindings_lets next)),
{
ctx with
subscope_vars =
@ -659,7 +630,7 @@ let translate_rule
defined, we add an check "ErrorOnEmpty" here. *)
Marked.mark
(Expr.map_ty (fun _ -> scope_let_typ) (Marked.get_mark e))
(EAssert (Marked.same_mark_as (ErrorOnEmpty new_e) e));
(EAssert (Marked.same_mark_as (EErrorOnEmpty new_e) e));
scope_let_kind = Assertion;
})
(Bindlib.bind_var (Var.make "_") next)
@ -671,7 +642,7 @@ let translate_rules
(rules : 'm Ast.rule list)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info)
(mark : 'm mark)
(sigma_return_struct_name : StructName.t) :
(scope_sig : 'm scope_sig_ctx) :
'm Dcalc.Ast.expr scope_body_expr Bindlib.box * 'm ctx =
let scope_lets, new_ctx =
List.fold_left
@ -683,19 +654,18 @@ let translate_rules
((fun next -> next), ctx)
rules
in
let scope_variables = ScopeVarMap.bindings new_ctx.scope_vars in
let scope_output_variables =
List.filter
(fun (_, (_, _, io)) -> Marked.unmark io.Ast.io_output)
scope_variables
in
let return_exp =
Expr.etuple
(List.map
(fun (_, (dcalc_var, _, _)) ->
Expr.make_var dcalc_var (mark_tany mark pos_sigma))
scope_output_variables)
(Some sigma_return_struct_name) (mark_tany mark pos_sigma)
Expr.estruct scope_sig.scope_sig_output_struct
(ScopeVarMap.fold
(fun var (dcalc_var, _, io) acc ->
if Marked.unmark io.Ast.io_output then
let field = ScopeVarMap.find var scope_sig.scope_sig_out_fields in
StructFieldMap.add field
(Expr.make_var dcalc_var (mark_tany mark pos_sigma))
acc
else acc)
new_ctx.scope_vars StructFieldMap.empty)
(mark_tany mark pos_sigma)
in
( scope_lets
(Bindlib.box_apply
@ -741,7 +711,7 @@ let translate_scope_decl
let pos_sigma = Marked.get_mark sigma_info in
let rules_with_return_expr, ctx =
translate_rules ctx sigma.scope_decl_rules sigma_info sigma.scope_mark
scope_return_struct_name
scope_sig
in
let scope_variables =
List.map
@ -770,42 +740,39 @@ let translate_scope_decl
| NoInput -> failwith "should not happen"
in
let input_destructurings next =
fst
(List.fold_right
(fun (var_ctx, v) (next, i) ->
( Bindlib.box_apply2
(fun next r ->
ScopeLet
{
scope_let_kind = DestructuringInputStruct;
scope_let_next = next;
scope_let_pos = pos_sigma;
scope_let_typ = input_var_typ var_ctx;
scope_let_expr =
( ETupleAccess
( r,
i,
Some scope_input_struct_name,
List.map
(fun (var_ctx, _) -> input_var_typ var_ctx)
scope_input_variables ),
mark_tany sigma.scope_mark pos_sigma );
})
(Bindlib.bind_var v next)
(Expr.Box.lift
(Expr.make_var scope_input_var
(mark_tany sigma.scope_mark pos_sigma))),
i - 1 ))
scope_input_variables
(next, List.length scope_input_variables - 1))
List.fold_right
(fun (var_ctx, v) next ->
let field =
Marked.unmark
(ScopeVarMap.find var_ctx.scope_var_name
scope_sig.scope_sig_in_fields)
in
Bindlib.box_apply2
(fun next r ->
ScopeLet
{
scope_let_kind = DestructuringInputStruct;
scope_let_next = next;
scope_let_pos = pos_sigma;
scope_let_typ = input_var_typ var_ctx;
scope_let_expr =
( EStructAccess
{ name = scope_input_struct_name; e = r; field },
mark_tany sigma.scope_mark pos_sigma );
})
(Bindlib.bind_var v next)
(Expr.Box.lift
(Expr.make_var scope_input_var
(mark_tany sigma.scope_mark pos_sigma))))
scope_input_variables next
in
let field_map =
List.map
(fun (var_ctx, _) ->
List.fold_left
(fun acc (var_ctx, _) ->
let var = var_ctx.scope_var_name in
let field, _ = ScopeVarMap.find var scope_sig.scope_sig_in_fields in
field, input_var_typ var_ctx)
scope_input_variables
StructFieldMap.add field (input_var_typ var_ctx) acc)
StructFieldMap.empty scope_input_variables
in
let new_struct_ctx = StructMap.singleton scope_input_struct_name field_map in
( Bindlib.box_apply
@ -831,9 +798,7 @@ let translate_program (prgm : 'm Ast.program) : 'm Dcalc.Ast.program =
Var.make
(Marked.unmark (ScopeName.get_info scope.Ast.scope_decl_name))
in
let scope_return_struct_name =
ScopeMap.find scope_name decl_ctx.ctx_scopes
in
let scope_return = ScopeMap.find scope_name decl_ctx.ctx_scopes in
let scope_input_var =
Var.make (Marked.unmark (ScopeName.get_info scope_name) ^ "_in")
in
@ -869,8 +834,9 @@ let translate_program (prgm : 'm Ast.program) : 'm Dcalc.Ast.program =
scope_sig_scope_var = scope_dvar;
scope_sig_input_var = scope_input_var;
scope_sig_input_struct = scope_input_struct_name;
scope_sig_output_struct = scope_return_struct_name;
scope_sig_output_struct = scope_return.out_struct_name;
scope_sig_in_fields;
scope_sig_out_fields = scope_return.out_struct_fields;
})
prgm.program_scopes
in

122
compiler/shared_ast/definitions.ml
View File

@ -197,60 +197,83 @@ type ('a, 't) gexpr = (('a, 't) naked_gexpr, 't) Marked.t
and ('a, 't) naked_gexpr =
(* Constructors common to all ASTs *)
| ELit : 'a glit -> ('a any, 't) naked_gexpr
| EApp : ('a, 't) gexpr * ('a, 't) gexpr list -> ('a any, 't) naked_gexpr
| EApp : {
f : ('a, 't) gexpr;
args : ('a, 't) gexpr list;
}
-> ('a any, 't) naked_gexpr
| EOp : operator -> ('a any, 't) naked_gexpr
| EArray : ('a, 't) gexpr list -> ('a any, 't) naked_gexpr
| EVar : ('a, 't) naked_gexpr Bindlib.var -> ('a any, 't) naked_gexpr
| EAbs :
(('a, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder * typ list
| EAbs : {
binder : (('a, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder;
tys : typ list;
}
-> ('a any, 't) naked_gexpr
| EIfThenElse :
('a, 't) gexpr * ('a, 't) gexpr * ('a, 't) gexpr
| EIfThenElse : {
cond : ('a, 't) gexpr;
etrue : ('a, 't) gexpr;
efalse : ('a, 't) gexpr;
}
-> ('a any, 't) naked_gexpr
| EStruct : {
name : StructName.t;
fields : ('a, 't) gexpr StructFieldMap.t;
}
-> ('a any, 't) naked_gexpr
| EStructAccess : {
name : StructName.t;
e : ('a, 't) gexpr;
field : StructFieldName.t;
}
-> ('a any, 't) naked_gexpr
| EInj : {
name : EnumName.t;
e : ('a, 't) gexpr;
cons : EnumConstructor.t;
}
-> ('a any, 't) naked_gexpr
| EMatch : {
name : EnumName.t;
e : ('a, 't) gexpr;
cases : ('a, 't) gexpr EnumConstructorMap.t;
}
-> ('a any, 't) naked_gexpr
(* Early stages *)
| ELocation :
'a glocation
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EStruct :
StructName.t * ('a, 't) gexpr StructFieldMap.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EStructAccess :
('a, 't) gexpr * StructFieldName.t * StructName.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EEnumInj :
('a, 't) gexpr * EnumConstructor.t * EnumName.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EMatchS :
('a, 't) gexpr * EnumName.t * ('a, 't) gexpr EnumConstructorMap.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EScopeCall :
ScopeName.t * ('a, 't) gexpr ScopeVarMap.t
| EScopeCall : {
scope : ScopeName.t;
args : ('a, 't) gexpr ScopeVarMap.t;
}
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
(* Lambda-like *)
| ETuple :
('a, 't) gexpr list * StructName.t option
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| ETupleAccess :
('a, 't) gexpr * int * StructName.t option * typ list
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| EInj :
('a, 't) gexpr * int * EnumName.t * typ list
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| EMatch :
('a, 't) gexpr * ('a, 't) gexpr list * EnumName.t
-> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
| EAssert : ('a, 't) gexpr -> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
(* Default terms *)
| EDefault :
('a, 't) gexpr list * ('a, 't) gexpr * ('a, 't) gexpr
| EDefault : {
excepts : ('a, 't) gexpr list;
just : ('a, 't) gexpr;
cons : ('a, 't) gexpr;
}
-> (([< desugared | scopelang | dcalc ] as 'a), 't) naked_gexpr
| ErrorOnEmpty :
| EErrorOnEmpty :
('a, 't) gexpr
-> (([< desugared | scopelang | dcalc ] as 'a), 't) naked_gexpr
(* Lambda calculus with exceptions *)
| ETuple : ('a, 't) gexpr list -> ((lcalc as 'a), 't) naked_gexpr
| ETupleAccess : {
e : ('a, 't) gexpr;
index : int;
size : int;
}
-> ((lcalc as 'a), 't) naked_gexpr
| ERaise : except -> ((lcalc as 'a), 't) naked_gexpr
| ECatch :
('a, 't) gexpr * except * ('a, 't) gexpr
| ECatch : {
body : ('a, 't) gexpr;
exn : except;
handler : ('a, 't) gexpr;
}
-> ((lcalc as 'a), 't) naked_gexpr
type ('a, 't) boxed_gexpr = (('a, 't) naked_gexpr Bindlib.box, 't) Marked.t
@ -276,9 +299,9 @@ type typed = { pos : Pos.t; ty : typ }
(** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when
appropriate. Expected to fill the ['t] parameter of [naked_gexpr] and
[gexpr] (a ['t] annotation different from this type is used in the middle of
the typing processing, but all visible ASTs should otherwise use this. *)
appropriate. Expected to fill the ['t] parameter of [gexpr] and [gexpr] (a
['t] annotation different from this type is used in the middle of the typing
processing, but all visible ASTs should otherwise use this. *)
type _ mark = Untyped : untyped -> untyped mark | Typed : typed -> typed mark
(** Useful for errors and printing, for example *)
@ -287,11 +310,10 @@ type any_expr = AnyExpr : (_, _ mark) gexpr -> any_expr
(** {2 Higher-level program structure} *)
(** Constructs scopes and programs on top of expressions. The ['e] type
parameter throughout is expected to match instances of the [naked_gexpr]
type defined above. Markings are constrained to the [mark] GADT defined
above. Note that this structure is at the moment only relevant for [dcalc]
and [lcalc], as [scopelang] has its own scope structure, as the name
implies. *)
parameter throughout is expected to match instances of the [gexpr] type
defined above. Markings are constrained to the [mark] GADT defined above.
Note that this structure is at the moment only relevant for [dcalc] and
[lcalc], as [scopelang] has its own scope structure, as the name implies. *)
(** This kind annotation signals that the let-binding respects a structural
invariant. These invariants concern the shape of the expression in the
@ -350,14 +372,18 @@ and 'e scopes =
| ScopeDef of 'e scope_def
constraint 'e = (_ any, _ mark) gexpr
type struct_ctx = (StructFieldName.t * typ) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ) list EnumMap.t
type struct_ctx = typ StructFieldMap.t StructMap.t
type enum_ctx = typ EnumConstructorMap.t EnumMap.t
type scope_out_struct = {
out_struct_name : StructName.t;
out_struct_fields : StructFieldName.t ScopeVarMap.t;
}
type decl_ctx = {
ctx_enums : enum_ctx;
ctx_structs : struct_ctx;
ctx_scopes : StructName.t ScopeMap.t;
(** The output structure type of every scope *)
ctx_scopes : scope_out_struct ScopeMap.t;
}
type 'e program = { decl_ctx : decl_ctx; scopes : 'e scopes }

426
compiler/shared_ast/expr.ml
View File

@ -76,61 +76,61 @@ let subst binder vars =
Bindlib.msubst binder (Array.of_list (List.map Marked.unmark vars))
let evar v mark = Marked.mark mark (Bindlib.box_var v)
let etuple args s = Box.appn args @@ fun args -> ETuple (args, s)
let etuple args = Box.appn args @@ fun args -> ETuple args
let etupleaccess e1 i s typs =
Box.app1 e1 @@ fun e1 -> ETupleAccess (e1, i, s, typs)
let einj e1 i e_name typs = Box.app1 e1 @@ fun e1 -> EInj (e1, i, e_name, typs)
let ematch arg arms e_name =
Box.app1n arg arms @@ fun arg arms -> EMatch (arg, arms, e_name)
let etupleaccess e index size =
assert (index < size);
Box.app1 e @@ fun e -> ETupleAccess { e; index; size }
let earray args = Box.appn args @@ fun args -> EArray args
let elit l mark = Marked.mark mark (Bindlib.box (ELit l))
let eabs binder typs mark =
Bindlib.box_apply (fun binder -> EAbs (binder, typs)) binder, mark
let eabs binder tys mark =
Bindlib.box_apply (fun binder -> EAbs { binder; tys }) binder, mark
let eapp e1 args = Box.app1n e1 args @@ fun e1 args -> EApp (e1, args)
let eapp f args = Box.app1n f args @@ fun f args -> EApp { f; args }
let eassert e1 = Box.app1 e1 @@ fun e1 -> EAssert e1
let eop op = Box.app0 @@ EOp op
let edefault excepts just cons =
Box.app2n just cons excepts
@@ fun just cons excepts -> EDefault (excepts, just, cons)
@@ fun just cons excepts -> EDefault { excepts; just; cons }
let eifthenelse e1 e2 e3 =
Box.app3 e1 e2 e3 @@ fun e1 e2 e3 -> EIfThenElse (e1, e2, e3)
let eifthenelse cond etrue efalse =
Box.app3 cond etrue efalse
@@ fun cond etrue efalse -> EIfThenElse { cond; etrue; efalse }
let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> ErrorOnEmpty e1
let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1
let eraise e1 = Box.app0 @@ ERaise e1
let ecatch e1 exn e2 = Box.app2 e1 e2 @@ fun e1 e2 -> ECatch (e1, exn, e2)
let ecatch body exn handler =
Box.app2 body handler @@ fun body handler -> ECatch { body; exn; handler }
let elocation loc = Box.app0 @@ ELocation loc
let estruct name (fields : ('a, 't) boxed_gexpr StructFieldMap.t) mark =
Marked.mark mark
@@ Bindlib.box_apply
(fun fields -> EStruct (name, fields))
(fun fields -> EStruct { name; fields })
(Box.lift_struct (StructFieldMap.map Box.lift fields))
let estructaccess e1 field struc =
Box.app1 e1 @@ fun e1 -> EStructAccess (e1, field, struc)
let estructaccess e field name =
Box.app1 e @@ fun e -> EStructAccess { name; e; field }
let eenuminj e1 cons enum = Box.app1 e1 @@ fun e1 -> EEnumInj (e1, cons, enum)
let einj e cons name = Box.app1 e @@ fun e -> EInj { name; e; cons }
let ematchs e1 enum cases mark =
let ematch e name cases mark =
Marked.mark mark
@@ Bindlib.box_apply2
(fun e1 cases -> EMatchS (e1, enum, cases))
(Box.lift e1)
(fun e cases -> EMatch { name; e; cases })
(Box.lift e)
(Box.lift_enum (EnumConstructorMap.map Box.lift cases))
let escopecall scope_name fields mark =
let escopecall scope args mark =
Marked.mark mark
@@ Bindlib.box_apply
(fun fields -> EScopeCall (scope_name, fields))
(Box.lift_scope_vars (ScopeVarMap.map Box.lift fields))
(fun args -> EScopeCall { scope; args })
(Box.lift_scope_vars (ScopeVarMap.map Box.lift args))
(* - Manipulation of marks - *)
@ -203,49 +203,44 @@ let maybe_ty (type m) ?(typ = TAny) (m : m mark) : typ =
(* shallow map *)
let map
(type a)
(ctx : 'ctx)
~(f : 'ctx -> (a, 'm1) gexpr -> (a, 'm2) boxed_gexpr)
~(f : (a, 'm1) gexpr -> (a, 'm2) boxed_gexpr)
(e : ((a, 'm1) naked_gexpr, 'm2) Marked.t) : (a, 'm2) boxed_gexpr =
let m = Marked.get_mark e in
match Marked.unmark e with
| ELit l -> elit l m
| EApp (e1, args) -> eapp (f ctx e1) (List.map (f ctx) args) m
| EApp { f = e1; args } -> eapp (f e1) (List.map f args) m
| EOp op -> eop op m
| EArray args -> earray (List.map (f ctx) args) m
| EArray args -> earray (List.map f args) m
| EVar v -> evar (Var.translate v) m
| EAbs (binder, typs) ->
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let body = f ctx body in
let body = f body in
let binder = bind (Array.map Var.translate vars) body in
eabs binder typs m
| EIfThenElse (e1, e2, e3) ->
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) m
| ETuple (args, s) -> etuple (List.map (f ctx) args) s m
| ETupleAccess (e1, n, s_name, typs) ->
etupleaccess ((f ctx) e1) n s_name typs m
| EInj (e1, i, e_name, typs) -> einj ((f ctx) e1) i e_name typs m
| EMatch (arg, arms, e_name) ->
ematch ((f ctx) arg) (List.map (f ctx) arms) e_name m
| EAssert e1 -> eassert ((f ctx) e1) m
| EDefault (excepts, just, cons) ->
edefault (List.map (f ctx) excepts) ((f ctx) just) ((f ctx) cons) m
| ErrorOnEmpty e1 -> eerroronempty ((f ctx) e1) m
| ECatch (e1, exn, e2) -> ecatch (f ctx e1) exn (f ctx e2) m
eabs binder tys m
| EIfThenElse { cond; etrue; efalse } ->
eifthenelse (f cond) (f etrue) (f efalse) m
| ETuple args -> etuple (List.map f args) m
| ETupleAccess { e; index; size } -> etupleaccess (f e) index size m
| EInj { e; name; cons } -> einj (f e) cons name m
| EAssert e1 -> eassert (f e1) m
| EDefault { excepts; just; cons } ->
edefault (List.map f excepts) (f just) (f cons) m
| EErrorOnEmpty e1 -> eerroronempty (f e1) m
| ECatch { body; exn; handler } -> ecatch (f body) exn (f handler) m
| ERaise exn -> eraise exn m
| ELocation loc -> elocation loc m
| EStruct (name, fields) ->
let fields = StructFieldMap.map (f ctx) fields in
| EStruct { name; fields } ->
let fields = StructFieldMap.map f fields in
estruct name fields m
| EStructAccess (e1, field, struc) -> estructaccess (f ctx e1) field struc m
| EEnumInj (e1, cons, enum) -> eenuminj (f ctx e1) cons enum m
| EMatchS (e1, enum, cases) ->
let cases = EnumConstructorMap.map (f ctx) cases in
ematchs (f ctx e1) enum cases m
| EScopeCall (scope_name, fields) ->
let fields = ScopeVarMap.map (f ctx) fields in
escopecall scope_name fields m
| EStructAccess { e; field; name } -> estructaccess (f e) field name m
| EMatch { e; name; cases } ->
let cases = EnumConstructorMap.map f cases in
ematch (f e) name cases m
| EScopeCall { scope; args } ->
let fields = ScopeVarMap.map f args in
escopecall scope fields m
let rec map_top_down ~f e = map () ~f:(fun () -> map_top_down ~f) (f e)
let rec map_top_down ~f e = map ~f:(map_top_down ~f) (f e)
let map_marks ~f e =
map_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
@ -260,31 +255,126 @@ let shallow_fold
let lfold x acc = List.fold_left (fun acc x -> f x acc) acc x in
match Marked.unmark e with
| ELit _ | EOp _ | EVar _ | ERaise _ | ELocation _ -> acc
| EApp (e1, args) -> acc |> f e1 |> lfold args
| EApp { f = e; args } -> acc |> f e |> lfold args
| EArray args -> acc |> lfold args
| EAbs _ -> acc
| EIfThenElse (e1, e2, e3) -> acc |> f e1 |> f e2 |> f e3
| ETuple (args, _) -> acc |> lfold args
| ETupleAccess (e1, _, _, _) -> acc |> f e1
| EInj (e1, _, _, _) -> acc |> f e1
| EMatch (arg, arms, _) -> acc |> f arg |> lfold arms
| EAssert e1 -> acc |> f e1
| EDefault (excepts, just, cons) -> acc |> lfold excepts |> f just |> f cons
| ErrorOnEmpty e1 -> acc |> f e1
| ECatch (e1, _, e2) -> acc |> f e1 |> f e2
| EStruct (_, fields) -> acc |> StructFieldMap.fold (fun _ -> f) fields
| EStructAccess (e1, _, _) -> acc |> f e1
| EEnumInj (e1, _, _) -> acc |> f e1
| EMatchS (e1, _, cases) ->
acc |> f e1 |> EnumConstructorMap.fold (fun _ -> f) cases
| EScopeCall (_, fields) -> acc |> ScopeVarMap.fold (fun _ -> f) fields
| EIfThenElse { cond; etrue; efalse } -> acc |> f cond |> f etrue |> f efalse
| ETuple args -> acc |> lfold args
| ETupleAccess { e; _ } -> acc |> f e
| EInj { e; _ } -> acc |> f e
| EAssert e -> acc |> f e
| EDefault { excepts; just; cons } -> acc |> lfold excepts |> f just |> f cons
| EErrorOnEmpty e -> acc |> f e
| ECatch { body; handler; _ } -> acc |> f body |> f handler
| EStruct { fields; _ } -> acc |> StructFieldMap.fold (fun _ -> f) fields
| EStructAccess { e; _ } -> acc |> f e
| EMatch { e; cases; _ } ->
acc |> f e |> EnumConstructorMap.fold (fun _ -> f) cases
| EScopeCall { args; _ } -> acc |> ScopeVarMap.fold (fun _ -> f) args
(* Like [map], but also allows to gather a result bottom-up. *)
let map_gather
(type a)
~(acc : 'acc)
~(join : 'acc -> 'acc -> 'acc)
~(f : (a, 'm1) gexpr -> 'acc * (a, 'm2) boxed_gexpr)
(e : ((a, 'm1) naked_gexpr, 'm2) Marked.t) : 'acc * (a, 'm2) boxed_gexpr =
let m = Marked.get_mark e in
let lfoldmap es =
let acc, r_es =
List.fold_left
(fun (acc, es) e ->
let acc1, e = f e in
join acc acc1, e :: es)
(acc, []) es
in
acc, List.rev r_es
in
match Marked.unmark e with
| ELit l -> acc, elit l m
| EApp { f = e1; args } ->
let acc1, f = f e1 in
let acc2, args = lfoldmap args in
join acc1 acc2, eapp f args m
| EOp op -> acc, eop op m
| EArray args ->
let acc, args = lfoldmap args in
acc, earray args m
| EVar v -> acc, evar (Var.translate v) m
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let acc, body = f body in
let binder = bind (Array.map Var.translate vars) body in
acc, eabs binder tys m
| EIfThenElse { cond; etrue; efalse } ->
let acc1, cond = f cond in
let acc2, etrue = f etrue in
let acc3, efalse = f efalse in
join (join acc1 acc2) acc3, eifthenelse cond etrue efalse m
| ETuple args ->
let acc, args = lfoldmap args in
acc, etuple args m
| ETupleAccess { e; index; size } ->
let acc, e = f e in
acc, etupleaccess e index size m
| EInj { e; name; cons } ->
let acc, e = f e in
acc, einj e cons name m
| EAssert e ->
let acc, e = f e in
acc, eassert e m
| EDefault { excepts; just; cons } ->
let acc1, excepts = lfoldmap excepts in
let acc2, just = f just in
let acc3, cons = f cons in
join (join acc1 acc2) acc3, edefault excepts just cons m
| EErrorOnEmpty e ->
let acc, e = f e in
acc, eerroronempty e m
| ECatch { body; exn; handler } ->
let acc1, body = f body in
let acc2, handler = f handler in
join acc1 acc2, ecatch body exn handler m
| ERaise exn -> acc, eraise exn m
| ELocation loc -> acc, elocation loc m
| EStruct { name; fields } ->
let acc, fields =
StructFieldMap.fold
(fun cons e (acc, fields) ->
let acc1, e = f e in
join acc acc1, StructFieldMap.add cons e fields)
fields
(acc, StructFieldMap.empty)
in
acc, estruct name fields m
| EStructAccess { e; field; name } ->
let acc, e = f e in
acc, estructaccess e field name m
| EMatch { e; name; cases } ->
let acc, e = f e in
let acc, cases =
EnumConstructorMap.fold
(fun cons e (acc, cases) ->
let acc1, e = f e in
join acc acc1, EnumConstructorMap.add cons e cases)
cases
(acc, EnumConstructorMap.empty)
in
acc, ematch e name cases m
| EScopeCall { scope; args } ->
let acc, args =
ScopeVarMap.fold
(fun var e (acc, args) ->
let acc1, e = f e in
join acc acc1, ScopeVarMap.add var e args)
args (acc, ScopeVarMap.empty)
in
acc, escopecall scope args m
(* - *)
(** See [Bindlib.box_term] documentation for why we are doing that. *)
let rebox e =
let rec id_t () e = map () ~f:id_t e in
id_t () e
let rec rebox e = map ~f:rebox e
let box e = Marked.same_mark_as (Bindlib.box (Marked.unmark e)) e
let unbox (e, m) = Bindlib.unbox e, m
@ -567,50 +657,56 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
fun e1 e2 ->
match Marked.unmark e1, Marked.unmark e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2
| ETuple (es1, n1), ETuple (es2, n2) -> n1 = n2 && equal_list es1 es2
| ETupleAccess (e1, id1, n1, tys1), ETupleAccess (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typ_list tys1 tys2
| EInj (e1, id1, n1, tys1), EInj (e2, id2, n2, tys2) ->
equal e1 e2 && id1 = id2 && n1 = n2 && equal_typ_list tys1 tys2
| EMatch (e1, cases1, n1), EMatch (e2, cases2, n2) ->
n1 = n2 && equal e1 e2 && equal_list cases1 cases2
| ETuple es1, ETuple es2 -> equal_list es1 es2
| ( ETupleAccess { e = e1; index = id1; size = s1 },
ETupleAccess { e = e2; index = id2; size = s2 } ) ->
s1 = s2 && equal e1 e2 && id1 = id2
| EArray es1, EArray es2 -> equal_list es1 es2
| ELit l1, ELit l2 -> l1 = l2
| EAbs (b1, tys1), EAbs (b2, tys2) ->
| EAbs { binder = b1; tys = tys1 }, EAbs { binder = b2; tys = tys2 } ->
equal_typ_list tys1 tys2
&&
let vars1, body1 = Bindlib.unmbind b1 in
let body2 = Bindlib.msubst b2 (Array.map (fun x -> EVar x) vars1) in
equal body1 body2
| EApp (e1, args1), EApp (e2, args2) -> equal e1 e2 && equal_list args1 args2
| EApp { f = e1; args = args1 }, EApp { f = e2; args = args2 } ->
equal e1 e2 && equal_list args1 args2
| EAssert e1, EAssert e2 -> equal e1 e2
| EOp op1, EOp op2 -> equal_ops op1 op2
| EDefault (exc1, def1, cons1), EDefault (exc2, def2, cons2) ->
| ( EDefault { excepts = exc1; just = def1; cons = cons1 },
EDefault { excepts = exc2; just = def2; cons = cons2 } ) ->
equal def1 def2 && equal cons1 cons2 && equal_list exc1 exc2
| EIfThenElse (if1, then1, else1), EIfThenElse (if2, then2, else2) ->
| ( EIfThenElse { cond = if1; etrue = then1; efalse = else1 },
EIfThenElse { cond = if2; etrue = then2; efalse = else2 } ) ->
equal if1 if2 && equal then1 then2 && equal else1 else2
| ErrorOnEmpty e1, ErrorOnEmpty e2 -> equal e1 e2
| EErrorOnEmpty e1, EErrorOnEmpty e2 -> equal e1 e2
| ERaise ex1, ERaise ex2 -> equal_except ex1 ex2
| ECatch (etry1, ex1, ewith1), ECatch (etry2, ex2, ewith2) ->
| ( ECatch { body = etry1; exn = ex1; handler = ewith1 },
ECatch { body = etry2; exn = ex2; handler = ewith2 } ) ->
equal etry1 etry2 && equal_except ex1 ex2 && equal ewith1 ewith2
| ELocation l1, ELocation l2 ->
equal_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
| EStruct (s1, fields1), EStruct (s2, fields2) ->
| ( EStruct { name = s1; fields = fields1 },
EStruct { name = s2; fields = fields2 } ) ->
StructName.equal s1 s2 && StructFieldMap.equal equal fields1 fields2
| EStructAccess (e1, f1, s1), EStructAccess (e2, f2, s2) ->
| ( EStructAccess { e = e1; field = f1; name = s1 },
EStructAccess { e = e2; field = f2; name = s2 } ) ->
StructName.equal s1 s2 && StructFieldName.equal f1 f2 && equal e1 e2
| EEnumInj (e1, c1, n1), EEnumInj (e2, c2, n2) ->
| EInj { e = e1; cons = c1; name = n1 }, EInj { e = e2; cons = c2; name = n2 }
->
EnumName.equal n1 n2 && EnumConstructor.equal c1 c2 && equal e1 e2
| EMatchS (e1, n1, cases1), EMatchS (e2, n2, cases2) ->
| ( EMatch { e = e1; name = n1; cases = cases1 },
EMatch { e = e2; name = n2; cases = cases2 } ) ->
EnumName.equal n1 n2
&& equal e1 e2
&& EnumConstructorMap.equal equal cases1 cases2
| EScopeCall (s1, fields1), EScopeCall (s2, fields2) ->
| ( EScopeCall { scope = s1; args = fields1 },
EScopeCall { scope = s2; args = fields2 } ) ->
ScopeName.equal s1 s2 && ScopeVarMap.equal equal fields1 fields2
| ( ( EVar _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | EArray _
| ELit _ | EAbs _ | EApp _ | EAssert _ | EOp _ | EDefault _
| EIfThenElse _ | ErrorOnEmpty _ | ERaise _ | ECatch _ | ELocation _
| EStruct _ | EStructAccess _ | EEnumInj _ | EMatchS _ | EScopeCall _ ),
| ( ( EVar _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _ | EAbs _ | EApp _
| EAssert _ | EOp _ | EDefault _ | EIfThenElse _ | EErrorOnEmpty _
| ERaise _ | ECatch _ | ELocation _ | EStruct _ | EStructAccess _ | EInj _
| EMatch _ | EScopeCall _ ),
_ ) ->
false
@ -623,7 +719,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
match[@ocamlformat "disable"] Marked.unmark e1, Marked.unmark e2 with
| ELit l1, ELit l2 ->
compare_lit l1 l2
| EApp (f1, args1), EApp (f2, args2) ->
| EApp {f=f1; args= args1}, EApp {f=f2; args= args2} ->
compare f1 f2 @@< fun () ->
List.compare compare args1 args2
| EOp op1, EOp op2 ->
@ -632,63 +728,52 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
List.compare compare a1 a2
| EVar v1, EVar v2 ->
Bindlib.compare_vars v1 v2
| EAbs (binder1, typs1), EAbs (binder2, typs2) ->
| EAbs {binder=binder1; tys= typs1}, EAbs {binder=binder2; tys= typs2} ->
List.compare compare_typ typs1 typs2 @@< fun () ->
let _, e1, e2 = Bindlib.unmbind2 binder1 binder2 in
compare e1 e2
| EIfThenElse (i1, t1, e1), EIfThenElse (i2, t2, e2) ->
| EIfThenElse {cond=i1; etrue= t1; efalse= e1}, EIfThenElse {cond=i2; etrue= t2; efalse= e2} ->
compare i1 i2 @@< fun () ->
compare t1 t2 @@< fun () ->
compare e1 e2
| ELocation l1, ELocation l2 ->
compare_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
| EStruct (name1, field_map1), EStruct (name2, field_map2) ->
| EStruct {name=name1; fields= field_map1}, EStruct {name=name2; fields= field_map2} ->
StructName.compare name1 name2 @@< fun () ->
StructFieldMap.compare compare field_map1 field_map2
| EStructAccess (e1, field_name1, struct_name1),
EStructAccess (e2, field_name2, struct_name2) ->
| EStructAccess {e=e1; field= field_name1; name= struct_name1},
EStructAccess {e=e2; field= field_name2; name= struct_name2} ->
compare e1 e2 @@< fun () ->
StructFieldName.compare field_name1 field_name2 @@< fun () ->
StructName.compare struct_name1 struct_name2
| EEnumInj (e1, cstr1, name1), EEnumInj (e2, cstr2, name2) ->
compare e1 e2 @@< fun () ->
| EMatch {e=e1; name= name1;cases= emap1}, EMatch {e=e2; name= name2;cases= emap2} ->
EnumName.compare name1 name2 @@< fun () ->
EnumConstructor.compare cstr1 cstr2
| EMatchS (e1, name1, emap1), EMatchS (e2, name2, emap2) ->
compare e1 e2 @@< fun () ->
EnumName.compare name1 name2 @@< fun () ->
EnumConstructorMap.compare compare emap1 emap2
| EScopeCall (name1, field_map1), EScopeCall (name2, field_map2) ->
| EScopeCall {scope=name1; args= field_map1}, EScopeCall {scope=name2; args= field_map2} ->
ScopeName.compare name1 name2 @@< fun () ->
ScopeVarMap.compare compare field_map1 field_map2
| ETuple (es1, s1), ETuple (es2, s2) ->
Option.compare StructName.compare s1 s2 @@< fun () ->
| ETuple es1, ETuple es2 ->
List.compare compare es1 es2
| ETupleAccess (e1, n1, s1, tys1), ETupleAccess (e2, n2, s2, tys2) ->
Option.compare StructName.compare s1 s2 @@< fun () ->
| ETupleAccess {e=e1; index= n1; size=s1}, ETupleAccess {e=e2; index= n2; size=s2} ->
Int.compare s1 s2 @@< fun () ->
Int.compare n1 n2 @@< fun () ->
List.compare compare_typ tys1 tys2 @@< fun () ->
compare e1 e2
| EInj (e1, n1, name1, ts1), EInj (e2, n2, name2, ts2) ->
| EInj {e=e1; name= name1; cons= cons1}, EInj {e=e2; name= name2; cons= cons2} ->
EnumName.compare name1 name2 @@< fun () ->
Int.compare n1 n2 @@< fun () ->
List.compare compare_typ ts1 ts2 @@< fun () ->
EnumConstructor.compare cons1 cons2 @@< fun () ->
compare e1 e2
| EMatch (e1, cases1, n1), EMatch (e2, cases2, n2) ->
EnumName.compare n1 n2 @@< fun () ->
compare e1 e2 @@< fun () ->
List.compare compare cases1 cases2
| EAssert e1, EAssert e2 ->
compare e1 e2
| EDefault (exs1, just1, cons1), EDefault (exs2, just2, cons2) ->
| EDefault {excepts=exs1; just= just1; cons=cons1}, EDefault {excepts=exs2; just= just2; cons=cons2} ->
compare just1 just2 @@< fun () ->
compare cons1 cons2 @@< fun () ->
List.compare compare exs1 exs2
| ErrorOnEmpty e1, ErrorOnEmpty e2 ->
| EErrorOnEmpty e1, EErrorOnEmpty e2 ->
compare e1 e2
| ERaise ex1, ERaise ex2 ->
compare_except ex1 ex2
| ECatch (etry1, ex1, ewith1), ECatch (etry2, ex2, ewith2) ->
| ECatch {body=etry1; exn= ex1; handler=ewith1}, ECatch {body=etry2; exn= ex2; handler=ewith2} ->
compare_except ex1 ex2 @@< fun () ->
compare etry1 etry2 @@< fun () ->
compare ewith1 ewith2
@ -702,33 +787,31 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| ELocation _, _ -> -1 | _, ELocation _ -> 1
| EStruct _, _ -> -1 | _, EStruct _ -> 1
| EStructAccess _, _ -> -1 | _, EStructAccess _ -> 1
| EEnumInj _, _ -> -1 | _, EEnumInj _ -> 1
| EMatchS _, _ -> -1 | _, EMatchS _ -> 1
| EMatch _, _ -> -1 | _, EMatch _ -> 1
| EScopeCall _, _ -> -1 | _, EScopeCall _ -> 1
| ETuple _, _ -> -1 | _, ETuple _ -> 1
| ETupleAccess _, _ -> -1 | _, ETupleAccess _ -> 1
| EInj _, _ -> -1 | _, EInj _ -> 1
| EMatch _, _ -> -1 | _, EMatch _ -> 1
| EAssert _, _ -> -1 | _, EAssert _ -> 1
| EDefault _, _ -> -1 | _, EDefault _ -> 1
| ErrorOnEmpty _, _ -> . | _, ErrorOnEmpty _ -> .
| EErrorOnEmpty _, _ -> . | _, EErrorOnEmpty _ -> .
| ERaise _, _ -> -1 | _, ERaise _ -> 1
| ECatch _, _ -> . | _, ECatch _ -> .
let rec free_vars : type a. (a, 't) gexpr -> (a, 't) gexpr Var.Set.t = function
| EVar v, _ -> Var.Set.singleton v
| EAbs (binder, _), _ ->
| EAbs { binder; _ }, _ ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right Var.Set.remove vs (free_vars body)
| e -> shallow_fold (fun e -> Var.Set.union (free_vars e)) e Var.Set.empty
let remove_logging_calls e =
let rec f () e =
let rec f e =
match Marked.unmark e with
| EApp ((EOp (Unop (Log _)), _), [arg]) -> map () ~f arg
| _ -> map () ~f e
| EApp { f = EOp (Unop (Log _)), _; args = [arg] } -> map ~f arg
| _ -> map ~f e
in
f () e
f e
let format ?debug decl_ctx ppf e = Print.expr ?debug decl_ctx ppf e
@ -736,36 +819,34 @@ let rec size : type a. (a, 't) gexpr -> int =
fun e ->
match Marked.unmark e with
| EVar _ | ELit _ | EOp _ -> 1
| ETuple (args, _) -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| ETuple args -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| EArray args -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| ETupleAccess (e1, _, _, _) -> size e1 + 1
| EInj (e1, _, _, _) -> size e1 + 1
| EAssert e1 -> size e1 + 1
| ErrorOnEmpty e1 -> size e1 + 1
| EMatch (arg, args, _) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EApp (arg, args) ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size arg) args
| EAbs (binder, _) ->
| ETupleAccess { e; _ } -> size e + 1
| EInj { e; _ } -> size e + 1
| EAssert e -> size e + 1
| EErrorOnEmpty e -> size e + 1
| EApp { f; args } ->
List.fold_left (fun acc arg -> acc + size arg) (1 + size f) args
| EAbs { binder; _ } ->
let _, body = Bindlib.unmbind binder in
1 + size body
| EIfThenElse (e1, e2, e3) -> 1 + size e1 + size e2 + size e3
| EDefault (exceptions, just, cons) ->
| EIfThenElse { cond; etrue; efalse } ->
1 + size cond + size etrue + size efalse
| EDefault { excepts; just; cons } ->
List.fold_left
(fun acc except -> acc + size except)
(1 + size just + size cons)
exceptions
excepts
| ERaise _ -> 1
| ECatch (etry, _, ewith) -> 1 + size etry + size ewith
| ECatch { body; handler; _ } -> 1 + size body + size handler
| ELocation _ -> 1
| EStruct (_, fields) ->
| EStruct { fields; _ } ->
StructFieldMap.fold (fun _ e acc -> acc + 1 + size e) fields 0
| EStructAccess (e1, _, _) -> 1 + size e1
| EEnumInj (e1, _, _) -> 1 + size e1
| EMatchS (e1, _, cases) ->
EnumConstructorMap.fold (fun _ e acc -> acc + 1 + size e) cases (size e1)
| EScopeCall (_, fields) ->
ScopeVarMap.fold (fun _ e acc -> acc + 1 + size e) fields 1
| EStructAccess { e; _ } -> 1 + size e
| EMatch { e; cases; _ } ->
EnumConstructorMap.fold (fun _ e acc -> acc + 1 + size e) cases (size e)
| EScopeCall { args; _ } ->
ScopeVarMap.fold (fun _ e acc -> acc + 1 + size e) args 1
(* - Expression building helpers - *)
@ -818,50 +899,35 @@ let make_let_in x tau e1 e2 mpos =
let make_multiple_let_in xs taus e1s e2 mpos =
make_app (make_abs xs e2 taus mpos) e1s (pos e2)
let make_default_unboxed exceptions just cons =
let make_default_unboxed excepts just cons =
let rec bool_value = function
| ELit (LBool b), _ -> Some b
| EApp ((EOp (Unop (Log (l, _))), _), [e]), _
| EApp { f = EOp (Unop (Log (l, _))), _; args = [e]; _ }, _
when l <> PosRecordIfTrueBool
(* we don't remove the log calls corresponding to source code
definitions !*) ->
bool_value e
| _ -> None
in
match exceptions, bool_value just, cons with
match excepts, bool_value just, cons with
| [], Some true, cons -> Marked.unmark cons
| exceptions, Some true, (EDefault ([], just, cons), _) ->
EDefault (exceptions, just, cons)
| excepts, Some true, (EDefault { excepts = []; just; cons }, _) ->
EDefault { excepts; just; cons }
| [except], Some false, _ -> Marked.unmark except
| exceptions, _, cons -> EDefault (exceptions, just, cons)
| excepts, _, cons -> EDefault { excepts; just; cons }
let make_default exceptions just cons =
Box.app2n just cons exceptions
@@ fun just cons exceptions -> make_default_unboxed exceptions just cons
let make_tuple el structname m0 =
let make_tuple el m0 =
match el with
| [] ->
etuple [] structname
(with_ty m0
(match structname with
| Some n -> TStruct n, mark_pos m0
| None -> TTuple [], mark_pos m0))
| [] -> etuple [] (with_ty m0 (TTuple [], mark_pos m0))
| el ->
let m =
fold_marks
(fun posl -> List.hd posl)
(fun ml ->
let pos = (List.hd ml).pos in
match structname with
| Some n -> TStruct n, pos
| None -> TTuple (List.map (fun t -> t.ty) ml), pos)
(fun ml -> TTuple (List.map (fun t -> t.ty) ml), (List.hd ml).pos)
(List.map (fun e -> Marked.get_mark e) el)
in
etuple el structname m
let make_struct fieldmap structname m =
let fields =
List.rev (StructFieldMap.fold (fun _ e acc -> e :: acc) fieldmap [])
in
make_tuple fields (Some structname) m
etuple el m

115
compiler/shared_ast/expr.mli
View File

@ -43,34 +43,10 @@ val subst :
('a, 't) gexpr list ->
('a, 't) gexpr
val etuple :
(([< dcalc | lcalc ] as 'a), 't) boxed_gexpr list ->
StructName.t option ->
't ->
('a, 't) boxed_gexpr
val etuple : (lcalc, 't) boxed_gexpr list -> 't -> (lcalc, 't) boxed_gexpr
val etupleaccess :
(([< dcalc | lcalc ] as 'a), 't) boxed_gexpr ->
int ->
StructName.t option ->
typ list ->
't ->
('a, 't) boxed_gexpr
val einj :
(([< dcalc | lcalc ] as 'a), 't) boxed_gexpr ->
int ->
EnumName.t ->
typ list ->
't ->
('a, 't) boxed_gexpr
val ematch :
(([< dcalc | lcalc ] as 'a), 't) boxed_gexpr ->
('a, 't) boxed_gexpr list ->
EnumName.t ->
't ->
('a, 't) boxed_gexpr
(lcalc, 't) boxed_gexpr -> int -> int -> 't -> (lcalc, 't) boxed_gexpr
val earray : ('a any, 't) boxed_gexpr list -> 't -> ('a, 't) boxed_gexpr
val elit : 'a any glit -> 't -> ('a, 't) boxed_gexpr
@ -125,26 +101,26 @@ val elocation :
val estruct :
StructName.t ->
(([< desugared | scopelang ] as 'a), 't) boxed_gexpr StructFieldMap.t ->
('a any, 't) boxed_gexpr StructFieldMap.t ->
't ->
('a, 't) boxed_gexpr
val estructaccess :
(([< desugared | scopelang ] as 'a), 't) boxed_gexpr ->
('a any, 't) boxed_gexpr ->
StructFieldName.t ->
StructName.t ->
't ->
('a, 't) boxed_gexpr
val eenuminj :
(([< desugared | scopelang ] as 'a), 't) boxed_gexpr ->
val einj :
('a any, 't) boxed_gexpr ->
EnumConstructor.t ->
EnumName.t ->
't ->
('a, 't) boxed_gexpr
val ematchs :
(([< desugared | scopelang ] as 'a), 't) boxed_gexpr ->
val ematch :
('a any, 't) boxed_gexpr ->
EnumName.t ->
('a, 't) boxed_gexpr EnumConstructorMap.t ->
't ->
@ -194,28 +170,25 @@ val untype : ('a, 'm mark) gexpr -> ('a, untyped mark) boxed_gexpr
(** {2 Traversal functions} *)
val map :
'ctx ->
f:('ctx -> ('a, 't1) gexpr -> ('a, 't2) boxed_gexpr) ->
f:(('a, 't1) gexpr -> ('a, 't2) boxed_gexpr) ->
(('a, 't1) naked_gexpr, 't2) Marked.t ->
('a, 't2) boxed_gexpr
(** Flat (non-recursive) mapping on expressions.
(** Shallow mapping on expressions (non recursive): applies the given function
to all sub-terms of the given expression, and rebuilds the node.
If you want to apply a map transform to an expression, you can save up
writing a painful match over all the cases of the AST. For instance, if you
want to remove all errors on empty, you can write
When applying a map transform to an expression, this avoids expliciting all
cases that remain unchanged. For instance, if you want to remove all errors
on empty, you can write
{[
let remove_error_empty =
let rec f () e =
let rec f e =
match Marked.unmark e with
| ErrorOnEmpty e1 -> Expr.map () f e1
| _ -> Expr.map () f e
| ErrorOnEmpty e1 -> Expr.map f e1
| _ -> Expr.map f e
in
f () e
]}
The first argument of map_expr is an optional context that you can carry
around during your map traversal. *)
f e
]} *)
val map_top_down :
f:(('a, 't1) gexpr -> (('a, 't1) naked_gexpr, 't2) Marked.t) ->
@ -231,7 +204,42 @@ val shallow_fold :
(('a, 't) gexpr -> 'acc -> 'acc) -> ('a, 't) gexpr -> 'acc -> 'acc
(** Applies a function on all sub-terms of the given expression. Does not
recurse, and doesn't open binders. Useful as helper for recursive calls
within traversal functions *)
within traversal functions. This can be used to compute free variables with
e.g.:
{[
let rec free_vars = function
| EVar v, _ -> Var.Set.singleton v
| EAbs { binder; _ }, _ ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right Var.Set.remove vs (free_vars body)
| e ->
shallow_fold (fun e -> Var.Set.union (free_vars e)) e Var.Set.empty
]} *)
val map_gather :
acc:'acc ->
join:('acc -> 'acc -> 'acc) ->
f:(('a, 't1) gexpr -> 'acc * ('a, 't2) boxed_gexpr) ->
(('a, 't1) naked_gexpr, 't2) Marked.t ->
'acc * ('a, 't2) boxed_gexpr
(** Shallow mapping similar to [map], but additionally allows to gather an
accumulator bottom-up. [acc] is the accumulator value returned on terminal
nodes, and [join] is used to merge accumulators from the different sub-terms
of an expression. [acc] is assumed to be a neutral element for [join].
Typically used with a set of variables used in the rewrite:
{[
let rec rewrite e =
match Marked.unmark e with
| Specific_case ->
Var.Set.singleton x, some_rewrite_fun e
| _ ->
Expr.map_gather ~acc:Var.Set.empty ~join:Var.Set.union ~f:rewrite e
}]
See [Lcalc.closure_conversion] for a real-world example. *)
(** {2 Expression building helpers} *)
@ -289,21 +297,10 @@ val make_default :
- [<ex | false :- _>], when [ex] is a single exception, is rewritten as [ex] *)
val make_tuple :
(([< dcalc | lcalc ] as 'a), 'm mark) boxed_gexpr list ->
StructName.t option ->
'm mark ->
('a, 'm mark) boxed_gexpr
(lcalc, 'm mark) boxed_gexpr list -> 'm mark -> (lcalc, 'm mark) boxed_gexpr
(** Builds a tuple; the mark argument is only used as witness and for position
when building 0-uples *)
val make_struct :
(([< dcalc | lcalc ] as 'a), 'm mark) boxed_gexpr StructFieldMap.t ->
StructName.t ->
'm mark ->
('a, 'm mark) boxed_gexpr
(** Builds the tuple of values for the given struct with proper ordering,
assuming the structfieldmap contains the fields defined for structname *)
(** {2 Transformations} *)
val remove_logging_calls : ('a any, 't) gexpr -> ('a, 't) boxed_gexpr

129
compiler/shared_ast/print.ml
View File

@ -96,7 +96,7 @@ let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
StructFieldName.format_t field punctuation "\"" punctuation ":"
typ mty))
(StructMap.find s ctx.ctx_structs)
(StructFieldMap.bindings (StructMap.find s ctx.ctx_structs))
punctuation "}")
| TEnum e -> (
match ctx with
@ -109,7 +109,7 @@ let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
(fun fmt (case, mty) ->
Format.fprintf fmt "%a%a@ %a" enum_constructor case punctuation ":"
typ mty))
(EnumMap.find e ctx.ctx_enums)
(EnumConstructorMap.bindings (EnumMap.find e ctx.ctx_enums))
punctuation "]")
| TOption t -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "option" typ t
| TArrow (t1, t2) ->
@ -215,7 +215,7 @@ let var_debug fmt v =
let var fmt v = Format.pp_print_string fmt (Bindlib.name_of v)
let needs_parens (type a) (e : (a, _) gexpr) : bool =
match Marked.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
match Marked.unmark e with EAbs _ | EStruct _ -> true | _ -> false
let rec expr_aux :
type a.
@ -228,6 +228,7 @@ let rec expr_aux :
fun ?(debug = false) ctx bnd_ctx fmt e ->
let exprb bnd_ctx e = expr_aux ~debug ctx bnd_ctx e in
let expr e = exprb bnd_ctx e in
let var = if debug then var_debug else var in
let with_parens fmt e =
if needs_parens e then (
punctuation fmt "(";
@ -236,79 +237,28 @@ let rec expr_aux :
else expr fmt e
in
match Marked.unmark e with
| EVar v -> if debug then var_debug fmt v else var fmt v
| ETuple (es, None) ->
| EVar v -> var fmt v
| ETuple es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> expr fmt e))
es punctuation ")"
| ETuple (es, Some s) -> (
match ctx with
| None -> expr fmt (Marked.same_mark_as (ETuple (es, None)) e)
| Some ctx ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a%a%a@]@]" StructName.format_t
s punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
StructFieldName.format_t struct_field punctuation "\""
punctuation "=" expr e))
(List.combine es (List.map fst (StructMap.find s ctx.ctx_structs)))
punctuation "}")
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" punctuation "["
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> expr fmt e))
es punctuation "]"
| ETupleAccess (e1, n, s, _ts) -> (
match s, ctx with
| None, _ | _, None ->
expr fmt e1;
punctuation fmt ".";
Format.pp_print_int fmt n
| Some s, Some ctx ->
expr fmt e1;
operator fmt ".";
punctuation fmt "\"";
StructFieldName.format_t fmt
(fst (List.nth (StructMap.find s ctx.ctx_structs) n));
punctuation fmt "\"")
| EInj (e, n, en, _ts) -> (
match ctx with
| None ->
Format.fprintf fmt "@[<hov 2>%a[%d]@ %a@]" EnumName.format_t en n expr e
| Some ctx ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" enum_constructor
(fst (List.nth (EnumMap.find en ctx.ctx_enums) n))
expr e)
| EMatch (e, es, e_name) -> (
match ctx with
| None ->
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]" keyword "match"
expr e keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (e, i) ->
Format.fprintf fmt "@[<hov 2>%a %a[%d]%a@ %a@]" punctuation "|"
EnumName.format_t e_name i punctuation ":" expr e))
(List.mapi (fun i e -> e, i) es)
| Some ctx ->
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]" keyword "match"
expr e keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (e, c) ->
Format.fprintf fmt "@[<hov 2>%a %a%a@ %a@]" punctuation "|"
enum_constructor c punctuation ":" expr e))
(List.combine es (List.map fst (EnumMap.find e_name ctx.ctx_enums))))
| ETupleAccess { e; index; _ } ->
expr fmt e;
punctuation fmt ".";
Format.pp_print_int fmt index
| ELit l -> lit fmt l
| EApp ((EAbs (binder, taus), _), args) ->
| EApp { f = EAbs { binder; tys }, _; args } ->
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
let expr = exprb bnd_ctx in
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) taus in
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args in
Format.fprintf fmt "%a%a"
(Format.pp_print_list
@ -318,10 +268,10 @@ let rec expr_aux :
"let" var x punctuation ":" (typ ctx) tau punctuation "=" expr arg
keyword "in"))
xs_tau_arg expr body
| EAbs (binder, taus) ->
| EAbs { binder; tys } ->
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
let expr = exprb bnd_ctx in
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) taus in
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" punctuation "λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
@ -329,29 +279,30 @@ let rec expr_aux :
Format.fprintf fmt "%a%a%a %a%a" punctuation "(" var x punctuation
":" (typ ctx) tau punctuation ")"))
xs_tau punctuation "→" expr body
| EApp ((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2]) ->
| EApp { f = EOp (Binop ((Map | Filter) as op)), _; args = [arg1; arg2] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" binop op with_parens arg1
with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
| EApp { f = EOp (Binop op), _; args = [arg1; arg2] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" with_parens arg1 binop op
with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug -> expr fmt arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
| EApp { f = EOp (Unop (Log _)), _; args = [arg1] } when not debug ->
expr fmt arg1
| EApp { f = EOp (Unop op), _; args = [arg1] } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" unop op with_parens arg1
| EApp (f, args) ->
| EApp { f; args } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" expr f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
with_parens)
args
| EIfThenElse (e1, e2, e3) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" keyword "if" expr e1
keyword "then" expr e2 keyword "else" expr e3
| EIfThenElse { cond; etrue; efalse } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" keyword "if" expr
cond keyword "then" expr etrue keyword "else" expr efalse
| EOp (Ternop op) -> ternop fmt op
| EOp (Binop op) -> binop fmt op
| EOp (Unop op) -> unop fmt op
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
| EDefault { excepts; just; cons } ->
if List.length excepts = 0 then
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a%a@]" punctuation "⟨" expr just
punctuation "⊢" expr cons punctuation "⟩"
else
@ -359,21 +310,21 @@ let rec expr_aux :
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ",")
expr)
exceptions punctuation "|" expr just punctuation "⊢" expr cons
punctuation "⟩"
| ErrorOnEmpty e' ->
excepts punctuation "|" expr just punctuation "⊢" expr cons punctuation
"⟩"
| EErrorOnEmpty e' ->
Format.fprintf fmt "%a@ %a" operator "error_empty" with_parens e'
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" keyword "assert" punctuation "("
expr e' punctuation ")"
| ECatch (e1, exn, e2) ->
| ECatch { body; exn; handler } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a ->@ %a@]" keyword "try"
with_parens e1 keyword "with" except exn with_parens e2
with_parens body keyword "with" except exn with_parens handler
| ERaise exn ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
| ELocation loc -> location fmt loc
| EStruct (name, fields) ->
Format.fprintf fmt " @[<hov 2>%a@ %a@ %a@ %a@]" StructName.format_t name
| EStruct { name; fields } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]" StructName.format_t name
punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
@ -383,21 +334,21 @@ let rec expr_aux :
"=" expr field_expr))
(StructFieldMap.bindings fields)
punctuation "}"
| EStructAccess (e1, field, _) ->
Format.fprintf fmt "%a%a%a%a%a" expr e1 punctuation "." punctuation "\""
| EStructAccess { e; field; _ } ->
Format.fprintf fmt "%a%a%a%a%a" expr e punctuation "." punctuation "\""
StructFieldName.format_t field punctuation "\""
| EEnumInj (e1, cons, _) ->
Format.fprintf fmt "%a@ %a" EnumConstructor.format_t cons expr e1
| EMatchS (e1, _, cases) ->
| EInj { e; cons; _ } ->
Format.fprintf fmt "%a@ %a" EnumConstructor.format_t cons expr e
| EMatch { e; cases; _ } ->
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]" keyword "match"
expr e1 keyword "with"
expr e keyword "with"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cons_name, case_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]" punctuation "|"
enum_constructor cons_name punctuation "→" expr case_expr))
(EnumConstructorMap.bindings cases)
| EScopeCall (scope, fields) ->
| EScopeCall { scope; args } ->
Format.pp_open_hovbox fmt 2;
ScopeName.format_t fmt scope;
Format.pp_print_space fmt ();
@ -411,7 +362,7 @@ let rec expr_aux :
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\"" ScopeVar.format_t
field_name punctuation "\"" punctuation "=" expr field_expr)
fmt
(ScopeVarMap.bindings fields);
(ScopeVarMap.bindings args);
Format.pp_close_box fmt ();
punctuation fmt "}";
Format.pp_close_box fmt ()

1
compiler/shared_ast/print.mli
View File

@ -42,6 +42,7 @@ val log_entry : Format.formatter -> log_entry -> unit
val unop : Format.formatter -> unop -> unit
val except : Format.formatter -> except -> unit
val var : Format.formatter -> 'e Var.t -> unit
val var_debug : Format.formatter -> 'e Var.t -> unit
val expr :
?debug:bool (** [true] for debug printing *) ->

12
compiler/shared_ast/program.ml
View File

@ -22,6 +22,18 @@ let map_exprs ~f ~varf { scopes; decl_ctx } =
(fun scopes -> { scopes; decl_ctx })
(Scope.map_exprs ~f ~varf scopes)
let get_scope_body { scopes; _ } scope =
match
Scope.fold_left ~init:None
~f:(fun acc scope_def _ ->
if ScopeName.equal scope_def.scope_name scope then
Some scope_def.scope_body
else acc)
scopes
with
| None -> raise Not_found
| Some body -> body
let untype : 'm. ('a, 'm mark) gexpr program -> ('a, untyped mark) gexpr program
=
fun prg -> Bindlib.unbox (map_exprs ~f:Expr.untype ~varf:Var.translate prg)

3
compiler/shared_ast/program.mli
View File

@ -25,6 +25,9 @@ val map_exprs :
'expr1 program ->
'expr2 program Bindlib.box
val get_scope_body :
(([< dcalc | lcalc ], _) gexpr as 'e) program -> ScopeName.t -> 'e scope_body
val untype :
(([< dcalc | lcalc ] as 'a), 'm mark) gexpr program ->
('a, untyped mark) gexpr program

193
compiler/shared_ast/typing.ml
View File

@ -371,68 +371,116 @@ and typecheck_expr_top_down :
(Expr.format ctx) e
in
Expr.elocation loc (uf_mark (ast_to_typ ty))
| A.EStruct (s_name, fmap) ->
let mark = ty_mark (TStruct s_name) in
let str = A.StructMap.find s_name ctx.A.ctx_structs in
let fmap' =
(* This assumes that the fields in fmap and the struct type are already
ensured to be the same *)
| A.EStruct { name; fields } ->
let mark = ty_mark (TStruct name) in
let str = A.StructMap.find name ctx.A.ctx_structs in
let _check_fields : unit =
let missing_fields, extra_fields =
A.StructFieldMap.fold
(fun fld x (remaining, extra) ->
if A.StructFieldMap.mem fld remaining then
A.StructFieldMap.remove fld remaining, extra
else remaining, A.StructFieldMap.add fld x extra)
fields
(str, A.StructFieldMap.empty)
in
let errs =
List.map
(fun (f, ty) ->
( Some
(Format.asprintf "Missing field %a" A.StructFieldName.format_t f),
Marked.get_mark ty ))
(A.StructFieldMap.bindings missing_fields)
@ List.map
(fun (f, ef) ->
let dup = A.StructFieldMap.mem f str in
( Some
(Format.asprintf "%s field %a"
(if dup then "Duplicate" else "Unknown")
A.StructFieldName.format_t f),
Expr.pos ef ))
(A.StructFieldMap.bindings extra_fields)
in
if errs <> [] then
Errors.raise_multispanned_error errs
"Mismatching field definitions for structure %a" A.StructName.format_t
name
in
let fields' =
A.StructFieldMap.mapi
(fun f_name f_e ->
let f_ty = List.assoc f_name str in
let f_ty = A.StructFieldMap.find f_name str in
typecheck_expr_top_down ctx env (ast_to_typ f_ty) f_e)
fmap
fields
in
Expr.estruct s_name fmap' mark
| A.EStructAccess (e_struct, f_name, s_name) ->
let mark =
uf_mark
(ast_to_typ
(List.assoc f_name (A.StructMap.find s_name ctx.A.ctx_structs)))
Expr.estruct name fields' mark
| A.EStructAccess { e = e_struct; name; field } ->
let fld_ty =
let str =
try A.StructMap.find name ctx.A.ctx_structs
with Not_found ->
Errors.raise_spanned_error pos_e "No structure %a found"
A.StructName.format_t name
in
try A.StructFieldMap.find field str
with Not_found ->
Errors.raise_multispanned_error
[
None, pos_e;
( Some "Structure %a declared here",
Marked.get_mark (A.StructName.get_info name) );
]
"Structure %a doesn't define a field %a" A.StructName.format_t name
A.StructFieldName.format_t field
in
let mark = uf_mark (ast_to_typ fld_ty) in
let e_struct' =
typecheck_expr_top_down ctx env (unionfind (TStruct s_name)) e_struct
typecheck_expr_top_down ctx env (unionfind (TStruct name)) e_struct
in
Expr.estructaccess e_struct' f_name s_name mark
| A.EEnumInj (e_enum, c_name, e_name) ->
let mark = uf_mark (unionfind (TEnum e_name)) in
Expr.estructaccess e_struct' field name mark
| A.EInj { name; cons; e = e_enum } ->
let mark = uf_mark (unionfind (TEnum name)) in
let e_enum' =
typecheck_expr_top_down ctx env
(ast_to_typ (List.assoc c_name (A.EnumMap.find e_name ctx.A.ctx_enums)))
(ast_to_typ
(A.EnumConstructorMap.find cons
(A.EnumMap.find name ctx.A.ctx_enums)))
e_enum
in
Expr.eenuminj e_enum' c_name e_name mark
| A.EMatchS (e1, e_name, cases) ->
let cases_ty = A.EnumMap.find e_name ctx.A.ctx_enums in
Expr.einj e_enum' cons name mark
| A.EMatch { e = e1; name; cases } ->
let cases_ty = A.EnumMap.find name ctx.A.ctx_enums in
let t_ret = unionfind ~pos:e1 (TAny (Any.fresh ())) in
let mark = uf_mark t_ret in
let e1' = typecheck_expr_top_down ctx env (unionfind (TEnum e_name)) e1 in
let e1' = typecheck_expr_top_down ctx env (unionfind (TEnum name)) e1 in
let cases' =
A.EnumConstructorMap.mapi
(fun c_name e ->
let c_ty = List.assoc c_name cases_ty in
let c_ty = A.EnumConstructorMap.find c_name cases_ty in
let e_ty = unionfind ~pos:e (TArrow (ast_to_typ c_ty, t_ret)) in
typecheck_expr_top_down ctx env e_ty e)
cases
in
Expr.ematchs e1' e_name cases' mark
| A.EScopeCall (scope_name, fields) ->
let scope_out_struct = A.ScopeMap.find scope_name ctx.ctx_scopes in
Expr.ematch e1' name cases' mark
| A.EScopeCall { scope; args } ->
let scope_out_struct =
(A.ScopeMap.find scope ctx.ctx_scopes).out_struct_name
in
let mark = uf_mark (unionfind (TStruct scope_out_struct)) in
let vars = A.ScopeMap.find scope_name env.scopes in
let fields' =
let vars = A.ScopeMap.find scope env.scopes in
let args' =
A.ScopeVarMap.mapi
(fun name ->
typecheck_expr_top_down ctx env
(ast_to_typ (A.ScopeVarMap.find name vars)))
fields
args
in
Expr.escopecall scope_name fields' mark
Expr.escopecall scope args' mark
| A.ERaise ex -> Expr.eraise ex context_mark
| A.ECatch (e1, ex, e2) ->
let e1' = typecheck_expr_top_down ctx env tau e1 in
let e2' = typecheck_expr_top_down ctx env tau e2 in
Expr.ecatch e1' ex e2' context_mark
| A.ECatch { body; exn; handler } ->
let body' = typecheck_expr_top_down ctx env tau body in
let handler' = typecheck_expr_top_down ctx env tau handler in
Expr.ecatch body' exn handler' context_mark
| A.EVar v ->
let tau' =
match Env.get env v with
@ -443,62 +491,23 @@ and typecheck_expr_top_down :
in
Expr.evar (Var.translate v) (uf_mark tau')
| A.ELit lit -> Expr.elit lit (ty_mark (lit_type lit))
| A.ETuple (es, None) ->
| A.ETuple es ->
let tys = List.map (fun _ -> unionfind (TAny (Any.fresh ()))) es in
let mark = uf_mark (unionfind (TTuple tys)) in
let es' = List.map2 (typecheck_expr_top_down ctx env) tys es in
Expr.etuple es' None mark
| A.ETuple (es, Some s_name) ->
let tys =
List.map
(fun (_, ty) -> ast_to_typ ty)
(A.StructMap.find s_name ctx.A.ctx_structs)
Expr.etuple es' mark
| A.ETupleAccess { e = e1; index; size } ->
if index >= size then
Errors.raise_spanned_error (Expr.pos e)
"Tuple access out of bounds (%d/%d)" index size;
let tuple_ty =
TTuple
(List.init size (fun n ->
if n = index then tau else unionfind ~pos:e1 (TAny (Any.fresh ()))))
in
let mark = uf_mark (unionfind (TStruct s_name)) in
let es' = List.map2 (typecheck_expr_top_down ctx env) tys es in
Expr.etuple es' (Some s_name) mark
| A.ETupleAccess (e1, n, s, typs) ->
let typs' = List.map ast_to_typ typs in
let tuple_ty = match s with None -> TTuple typs' | Some s -> TStruct s in
let t1n =
try List.nth typs' n
with Not_found ->
Errors.raise_spanned_error (Expr.pos e1)
"Expression should have a tuple type with at least %d elements but \
only has %d"
n (List.length typs)
in
let mark = uf_mark t1n in
let e1' = typecheck_expr_top_down ctx env (unionfind tuple_ty) e1 in
Expr.etupleaccess e1' n s typs mark
| A.EInj (e1, n, e_name, ts) ->
let ts' = List.map ast_to_typ ts in
let ts_n =
try List.nth ts' n
with Not_found ->
Errors.raise_spanned_error (Expr.pos e)
"Expression should have a sum type with at least %d cases but only \
has %d"
n (List.length ts)
in
let mark = uf_mark (unionfind (TEnum e_name)) in
let e1' = typecheck_expr_top_down ctx env ts_n e1 in
Expr.einj e1' n e_name ts mark
| A.EMatch (e1, es, e_name) ->
let es' =
List.map2
(fun es' (_, c_ty) ->
typecheck_expr_top_down ctx env
(unionfind ~pos:es' (TArrow (ast_to_typ c_ty, tau)))
es')
es
(A.EnumMap.find e_name ctx.ctx_enums)
in
let e1' =
typecheck_expr_top_down ctx env (unionfind ~pos:e1 (TEnum e_name)) e1
in
Expr.ematch e1' es' e_name context_mark
| A.EAbs (binder, t_args) ->
let e1' = typecheck_expr_top_down ctx env (unionfind ~pos:e1 tuple_ty) e1 in
Expr.etupleaccess e1' index size context_mark
| A.EAbs { binder; tys = t_args } ->
if Bindlib.mbinder_arity binder <> List.length t_args then
Errors.raise_spanned_error (Expr.pos e)
"function has %d variables but was supplied %d types"
@ -522,8 +531,8 @@ and typecheck_expr_top_down :
in
let body' = typecheck_expr_top_down ctx env t_ret body in
let binder' = Bindlib.bind_mvar xs' (Expr.Box.lift body') in
Expr.eabs binder' t_args mark
| A.EApp (e1, args) ->
Expr.eabs binder' (List.map typ_to_ast tau_args) mark
| A.EApp { f = e1; args } ->
let t_args = List.map (fun _ -> unionfind (TAny (Any.fresh ()))) args in
let t_func =
List.fold_right
@ -534,14 +543,14 @@ and typecheck_expr_top_down :
let args' = List.map2 (typecheck_expr_top_down ctx env) t_args args in
Expr.eapp e1' args' context_mark
| A.EOp op -> Expr.eop op (uf_mark (op_type (Marked.mark pos_e op)))
| A.EDefault (excepts, just, cons) ->
| A.EDefault { excepts; just; cons } ->
let cons' = typecheck_expr_top_down ctx env tau cons in
let just' =
typecheck_expr_top_down ctx env (unionfind ~pos:just (TLit TBool)) just
in
let excepts' = List.map (typecheck_expr_top_down ctx env tau) excepts in
Expr.edefault excepts' just' cons' context_mark
| A.EIfThenElse (cond, et, ef) ->
| A.EIfThenElse { cond; etrue = et; efalse = ef } ->
let et' = typecheck_expr_top_down ctx env tau et in
let ef' = typecheck_expr_top_down ctx env tau ef in
let cond' =
@ -554,7 +563,7 @@ and typecheck_expr_top_down :
typecheck_expr_top_down ctx env (unionfind ~pos:e1 (TLit TBool)) e1
in
Expr.eassert e1' mark
| A.ErrorOnEmpty e1 ->
| A.EErrorOnEmpty e1 ->
let e1' = typecheck_expr_top_down ctx env tau e1 in
Expr.eerroronempty e1' context_mark
| A.EArray es ->

20
compiler/surface/desugaring.ml
View File

@ -145,7 +145,7 @@ let rec translate_expr
Expr.make_abs [| binding_var |] e2 [tau] pos)
(EnumMap.find enum_uid ctxt.enums)
in
Expr.ematchs
Expr.ematch
(translate_expr scope inside_definition_of ctxt e1_sub)
enum_uid cases emark
| IfThenElse (e_if, e_then, e_else) ->
@ -424,7 +424,7 @@ let rec translate_expr
let payload =
Option.map (translate_expr scope inside_definition_of ctxt) payload
in
Expr.eenuminj
Expr.einj
(match payload with
| Some e' -> e'
| None -> Expr.elit LUnit mark_constructor)
@ -438,7 +438,7 @@ let rec translate_expr
let payload =
Option.map (translate_expr scope inside_definition_of ctxt) payload
in
Expr.eenuminj
Expr.einj
(match payload with
| Some e' -> e'
| None -> Expr.elit LUnit mark_constructor)
@ -455,7 +455,7 @@ let rec translate_expr
disambiguate_match_and_build_expression scope inside_definition_of ctxt
cases
in
Expr.ematchs e1 e_uid cases_d emark
Expr.ematch e1 e_uid cases_d emark
| TestMatchCase (e1, pattern) ->
(match snd (Marked.unmark pattern) with
| None -> ()
@ -476,7 +476,7 @@ let rec translate_expr
[tau] pos)
(EnumMap.find enum_uid ctxt.enums)
in
Expr.ematchs
Expr.ematch
(translate_expr scope inside_definition_of ctxt e1)
enum_uid cases emark
| ArrayLit es -> Expr.earray (List.map rec_helper es) emark
@ -1269,16 +1269,14 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
{
Desugared.Ast.program_ctx =
{
ctx_structs =
StructMap.map StructFieldMap.bindings ctxt.Name_resolution.structs;
ctx_enums =
EnumMap.map EnumConstructorMap.bindings ctxt.Name_resolution.enums;
ctx_structs = ctxt.Name_resolution.structs;
ctx_enums = ctxt.Name_resolution.enums;
ctx_scopes =
Desugared.Ast.IdentMap.fold
(fun _ def acc ->
match def with
| Name_resolution.TScope (scope, struc) ->
ScopeMap.add scope struc acc
| Name_resolution.TScope (scope, scope_out_struct) ->
ScopeMap.add scope scope_out_struct acc
| _ -> acc)
ctxt.Name_resolution.typedefs ScopeMap.empty;
};

53
compiler/surface/name_resolution.ml
View File

@ -67,7 +67,7 @@ type var_sig = {
type typedef =
| TStruct of StructName.t
| TEnum of EnumName.t
| TScope of ScopeName.t * StructName.t
| TScope of ScopeName.t * scope_out_struct
(** Implicitly defined output struct *)
type context = {
@ -197,7 +197,7 @@ let get_enum ctxt id =
let get_struct ctxt id =
match Desugared.Ast.IdentMap.find (Marked.unmark id) ctxt.typedefs with
| TStruct id | TScope (_, id) -> id
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
| TEnum eid ->
Errors.raise_multispanned_error
[
@ -299,7 +299,8 @@ let rec process_base_typ
match Desugared.Ast.IdentMap.find_opt ident ctxt.typedefs with
| Some (TStruct s_uid) -> TStruct s_uid, typ_pos
| Some (TEnum e_uid) -> TEnum e_uid, typ_pos
| Some (TScope (_, s_uid)) -> TStruct s_uid, typ_pos
| Some (TScope (_, scope_str)) ->
TStruct scope_str.out_struct_name, typ_pos
| None ->
Errors.raise_spanned_error typ_pos
"Unknown type \"%a\", not a struct or enum previously declared"
@ -517,11 +518,40 @@ let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
StructFieldMap.empty ctxt.structs;
}
else
process_struct_decl ctxt
{
struct_decl_name = decl.scope_decl_name;
struct_decl_fields = output_fields;
}
let ctxt =
process_struct_decl ctxt
{
struct_decl_name = decl.scope_decl_name;
struct_decl_fields = output_fields;
}
in
let out_struct_fields =
let sco = ScopeMap.find scope_uid ctxt.scopes in
let str = get_struct ctxt decl.scope_decl_name in
Desugared.Ast.IdentMap.fold
(fun id var svmap ->
match var with
| SubScope _ -> svmap
| ScopeVar v -> (
try
let field =
StructMap.find str
(Desugared.Ast.IdentMap.find id ctxt.field_idmap)
in
ScopeVarMap.add v field svmap
with Not_found -> svmap))
sco.var_idmap ScopeVarMap.empty
in
let typedefs =
Desugared.Ast.IdentMap.update
(Marked.unmark decl.scope_decl_name)
(function
| Some (TScope (scope, { out_struct_name; _ })) ->
Some (TScope (scope, { out_struct_name; out_struct_fields }))
| _ -> assert false)
ctxt.typedefs
in
{ ctxt with typedefs }
let typedef_info = function
| TStruct t -> StructName.get_info t
@ -555,7 +585,12 @@ let process_name_item (ctxt : context) (item : Ast.code_item Marked.pos) :
ctxt with
typedefs =
Desugared.Ast.IdentMap.add name
(TScope (scope_uid, out_struct_uid))
(TScope
( scope_uid,
{
out_struct_name = out_struct_uid;
out_struct_fields = ScopeVarMap.empty;
} ))
ctxt.typedefs;
scopes =
ScopeMap.add scope_uid

2
compiler/surface/name_resolution.mli
View File

@ -67,7 +67,7 @@ type var_sig = {
type typedef =
| TStruct of StructName.t
| TEnum of EnumName.t
| TScope of ScopeName.t * StructName.t
| TScope of ScopeName.t * scope_out_struct
(** Implicitly defined output struct *)
type context = {

2
compiler/utils/errors.ml
View File

@ -26,7 +26,7 @@ exception StructuredError of (string * (string option * Pos.t) list)
let print_structured_error (msg : string) (pos : (string option * Pos.t) list) :
string =
Printf.sprintf "%s%s%s" msg
(if List.length pos = 0 then "" else "\n\n")
(if pos = [] then "" else "\n\n")
(String.concat "\n\n"
(List.map
(fun (msg, pos) ->

249
compiler/verification/conditions.ml
View File

@ -37,11 +37,11 @@ let conjunction (args : vc_return list) (mark : typed mark) : vc_return =
match args with hd :: tl -> hd, tl | [] -> (ELit (LBool true), mark), []
in
List.fold_left
(fun acc arg -> EApp ((EOp (Binop And), mark), [arg; acc]), mark)
(fun acc arg -> EApp { f = EOp (Binop And), mark; args = [arg; acc] }, mark)
acc list
let negation (arg : vc_return) (mark : typed mark) : vc_return =
EApp ((EOp (Unop Not), mark), [arg]), mark
EApp { f = EOp (Unop Not), mark; args = [arg] }, mark
let disjunction (args : vc_return list) (mark : typed mark) : vc_return =
let acc, list =
@ -49,7 +49,7 @@ let disjunction (args : vc_return list) (mark : typed mark) : vc_return =
in
List.fold_left
(fun (acc : vc_return) arg ->
EApp ((EOp (Binop Or), mark), [arg; acc]), mark)
EApp { f = EOp (Binop Or), mark; args = [arg; acc] }, mark)
acc list
(** [half_product \[a1,...,an\] \[b1,...,bm\] returns \[(a1,b1),...(a1,bn),...(an,b1),...(an,bm)\]] *)
@ -67,20 +67,22 @@ let half_product (l1 : 'a list) (l2 : 'b list) : ('a * 'b) list =
let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
typed expr =
match Marked.unmark e with
| ErrorOnEmpty
| EErrorOnEmpty
( EDefault
( [(EApp ((EVar x, _), [(ELit LUnit, _)]), _)],
(ELit (LBool true), _),
cons ),
{
excepts = [(EApp { f = EVar x, _; args = [(ELit LUnit, _)] }, _)];
just = ELit (LBool true), _;
cons;
},
_ )
when List.exists (fun x' -> Var.eq x x') ctx.input_vars ->
(* scope variables*)
cons
| EAbs (binder, [(TLit TUnit, _)]) ->
| EAbs { binder; tys = [(TLit TUnit, _)] } ->
(* context sub-scope variables *)
let _, body = Bindlib.unmbind binder in
body
| ErrorOnEmpty d ->
| EErrorOnEmpty d ->
d (* input subscope variables and non-input scope variable *)
| _ ->
Errors.raise_spanned_error (Expr.pos e)
@ -98,78 +100,61 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
expression. *)
let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
vc_return =
let out =
match Marked.unmark e with
| ETuple (args, _) | EArray args ->
conjunction
(List.map (generate_vc_must_not_return_empty ctx) args)
(Marked.get_mark e)
| EMatch (arg, arms, _) ->
conjunction
(List.map (generate_vc_must_not_return_empty ctx) (arg :: arms))
(Marked.get_mark e)
| ETupleAccess (e1, _, _, _)
| EInj (e1, _, _, _)
| EAssert e1
| ErrorOnEmpty e1 ->
(generate_vc_must_not_return_empty ctx) e1
| EAbs (binder, _typs) ->
(* Hot take: for a function never to return an empty error when called, it has to do
so whatever its input. So we universally quantify over the variable of the function
when inspecting the body, resulting in simply traversing through in the code here. *)
let _vars, body = Bindlib.unmbind binder in
(generate_vc_must_not_return_empty ctx) body
| EApp (f, args) ->
(* We assume here that function calls never return empty error, which implies
all functions have been checked never to return empty errors. *)
conjunction
(List.map (generate_vc_must_not_return_empty ctx) (f :: args))
(Marked.get_mark e)
| EIfThenElse (e1, e2, e3) ->
let e1_vc = generate_vc_must_not_return_empty ctx e1 in
let e2_vc = generate_vc_must_not_return_empty ctx e2 in
let e3_vc = generate_vc_must_not_return_empty ctx e3 in
conjunction
[e1_vc; EIfThenElse (e1, e2_vc, e3_vc), Marked.get_mark e]
(Marked.get_mark e)
| ELit LEmptyError -> Marked.same_mark_as (ELit (LBool false)) e
| EVar _
(* Per default calculus semantics, you cannot call a function with an argument
that evaluates to the empty error. Thus, all variable evaluate to non-empty-error terms. *)
| ELit _ | EOp _ ->
Marked.same_mark_as (ELit (LBool true)) e
| EDefault (exceptions, just, cons) ->
(* <e1 ... en | ejust :- econs > never returns empty if and only if:
- first we look if e1 .. en ejust can return empty;
- if no, we check that if ejust is true, whether econs can return empty.
*)
disjunction
(List.map (generate_vc_must_not_return_empty ctx) exceptions
@ [
conjunction
[
generate_vc_must_not_return_empty ctx just;
(let vc_just_expr =
generate_vc_must_not_return_empty ctx cons
in
( EIfThenElse
( just,
(* Comment from Alain: the justification is not checked for holding an default term.
In such cases, we need to encode the logic of the default terms within
the generation of the verification condition (Z3encoding.translate_expr).
Answer from Denis: Normally, there is a structural invariant from the
surface language to intermediate representation translation preventing
any default terms to appear in justifications.*)
vc_just_expr,
(ELit (LBool false), Marked.get_mark e) ),
Marked.get_mark e ));
]
(Marked.get_mark e);
])
(Marked.get_mark e)
in
out
[@@ocamlformat "wrap-comments=false"]
match Marked.unmark e with
| EAbs { binder; _ } ->
(* Hot take: for a function never to return an empty error when called, it
has to do so whatever its input. So we universally quantify over the
variable of the function when inspecting the body, resulting in simply
traversing through in the code here. *)
let _vars, body = Bindlib.unmbind binder in
(generate_vc_must_not_return_empty ctx) body
| EDefault { excepts; just; cons } ->
(* <e1 ... en | ejust :- econs > never returns empty if and only if: - first
we look if e1 .. en ejust can return empty; - if no, we check that if
ejust is true, whether econs can return empty. *)
disjunction
(List.map (generate_vc_must_not_return_empty ctx) excepts
@ [
conjunction
[
generate_vc_must_not_return_empty ctx just;
(let vc_just_expr = generate_vc_must_not_return_empty ctx cons in
( EIfThenElse
{
cond = just;
(* Comment from Alain: the justification is not checked for
holding an default term. In such cases, we need to
encode the logic of the default terms within the
generation of the verification condition
(Z3encoding.translate_expr). Answer from Denis:
Normally, there is a structural invariant from the
surface language to intermediate representation
translation preventing any default terms to appear in
justifications.*)
etrue = vc_just_expr;
efalse = ELit (LBool false), Marked.get_mark e;
},
Marked.get_mark e ));
]
(Marked.get_mark e);
])
(Marked.get_mark e)
| ELit LEmptyError -> Marked.same_mark_as (ELit (LBool false)) e
| EVar _
(* Per default calculus semantics, you cannot call a function with an argument
that evaluates to the empty error. Thus, all variable evaluate to
non-empty-error terms. *)
| ELit _ | EOp _ ->
Marked.same_mark_as (ELit (LBool true)) e
| _ ->
(* For the [EApp] case, We assume here that function calls never return
empty error, which implies all functions have been checked never to
return empty errors. *)
conjunction
(Expr.shallow_fold
(fun e acc -> generate_vc_must_not_return_empty ctx e :: acc)
e [])
(Marked.get_mark e)
(** [generate_vc_must_not_return_conflict e] returns the dcalc boolean
expression [b] such that if [b] is true, then [e] will never return a
@ -177,67 +162,45 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
variables inside the expression. *)
let rec generate_vc_must_not_return_conflict (ctx : ctx) (e : typed expr) :
vc_return =
let out =
(* See the code of [generate_vc_must_not_return_empty] for a list of invariants on which this
function relies on. *)
match Marked.unmark e with
| ETuple (args, _) | EArray args ->
conjunction
(List.map (generate_vc_must_not_return_conflict ctx) args)
(* See the code of [generate_vc_must_not_return_empty] for a list of
invariants on which this function relies on. *)
match Marked.unmark e with
| EAbs { binder; _ } ->
let _vars, body = Bindlib.unmbind binder in
(generate_vc_must_not_return_conflict ctx) body
| EVar _ | ELit _ | EOp _ -> Marked.same_mark_as (ELit (LBool true)) e
| EDefault { excepts; just; cons } ->
(* <e1 ... en | ejust :- econs > never returns conflict if and only if: -
neither e1 nor ... nor en nor ejust nor econs return conflict - there is
no two differents ei ej that are not empty. *)
let quadratic =
negation
(disjunction
(List.map
(fun (e1, e2) ->
conjunction
[
generate_vc_must_not_return_empty ctx e1;
generate_vc_must_not_return_empty ctx e2;
]
(Marked.get_mark e))
(half_product excepts excepts))
(Marked.get_mark e))
(Marked.get_mark e)
| EMatch (arg, arms, _) ->
conjunction
(List.map (generate_vc_must_not_return_conflict ctx) (arg :: arms))
(Marked.get_mark e)
| ETupleAccess (e1, _, _, _)
| EInj (e1, _, _, _)
| EAssert e1
| ErrorOnEmpty e1 ->
generate_vc_must_not_return_conflict ctx e1
| EAbs (binder, _typs) ->
let _vars, body = Bindlib.unmbind binder in
(generate_vc_must_not_return_conflict ctx) body
| EApp (f, args) ->
conjunction
(List.map (generate_vc_must_not_return_conflict ctx) (f :: args))
(Marked.get_mark e)
| EIfThenElse (e1, e2, e3) ->
let e1_vc = generate_vc_must_not_return_conflict ctx e1 in
let e2_vc = generate_vc_must_not_return_conflict ctx e2 in
let e3_vc = generate_vc_must_not_return_conflict ctx e3 in
conjunction
[e1_vc; EIfThenElse (e1, e2_vc, e3_vc), Marked.get_mark e]
(Marked.get_mark e)
| EVar _ | ELit _ | EOp _ -> Marked.same_mark_as (ELit (LBool true)) e
| EDefault (exceptions, just, cons) ->
(* <e1 ... en | ejust :- econs > never returns conflict if and only if:
- neither e1 nor ... nor en nor ejust nor econs return conflict
- there is no two differents ei ej that are not empty. *)
let quadratic =
negation
(disjunction
(List.map
(fun (e1, e2) ->
conjunction
[
generate_vc_must_not_return_empty ctx e1;
generate_vc_must_not_return_empty ctx e2;
]
(Marked.get_mark e))
(half_product exceptions exceptions))
(Marked.get_mark e))
(Marked.get_mark e)
in
let others =
List.map
(generate_vc_must_not_return_conflict ctx)
(just :: cons :: exceptions)
in
let out = conjunction (quadratic :: others) (Marked.get_mark e) in
out
in
out
[@@ocamlformat "wrap-comments=false"]
in
let others =
List.map
(generate_vc_must_not_return_conflict ctx)
(just :: cons :: excepts)
in
let out = conjunction (quadratic :: others) (Marked.get_mark e) in
out
| _ ->
conjunction
(Expr.shallow_fold
(fun e acc -> generate_vc_must_not_return_conflict ctx e :: acc)
e [])
(Marked.get_mark e)
(** {1 Interface}*)
@ -278,7 +241,7 @@ let rec generate_verification_conditions_scope_body_expr
let vc_confl = generate_vc_must_not_return_conflict ctx e in
let vc_confl =
if !Cli.optimize_flag then
Bindlib.unbox (Optimizations.optimize_expr ctx.decl vc_confl)
Expr.unbox (Optimizations.optimize_expr ctx.decl vc_confl)
else vc_confl
in
let vc_list =
@ -297,7 +260,7 @@ let rec generate_verification_conditions_scope_body_expr
let vc_empty = generate_vc_must_not_return_empty ctx e in
let vc_empty =
if !Cli.optimize_flag then
Bindlib.unbox (Optimizations.optimize_expr ctx.decl vc_empty)
Expr.unbox (Optimizations.optimize_expr ctx.decl vc_empty)
else vc_empty
in
{

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

@ -170,7 +170,8 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
(fun (fn, ty) e ->
Format.asprintf "-- %s : %s" (get_fieldname fn)
(print_z3model_expr ctx ty e))
s (Expr.get_args e)
(StructFieldMap.bindings s)
(Expr.get_args e)
in
let fields_str = String.concat " " fields in
@ -190,8 +191,9 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
let case =
List.find
(fun (ctr, _) ->
(* FIXME: don't match on strings *)
String.equal fd_name (Marked.unmark (EnumConstructor.get_info ctr)))
enum_ctrs
(EnumConstructorMap.bindings enum_ctrs)
in
Format.asprintf "%s (%s)" fd_name (print_z3model_expr ctx (snd case) e')
@ -284,9 +286,8 @@ let rec translate_typ (ctx : context) (t : naked_typ) : context * Sort.sort =
and find_or_create_enum (ctx : context) (enum : EnumName.t) :
context * Sort.sort =
(* Creates a Z3 constructor corresponding to the Catala constructor [c] *)
let create_constructor (ctx : context) (c : EnumConstructor.t * typ) :
let create_constructor (name : EnumConstructor.t) (ty : typ) (ctx : context) :
context * Datatype.Constructor.constructor =
let name, ty = c in
let name = Marked.unmark (EnumConstructor.get_info name) in
let ctx, arg_z3_ty = translate_typ ctx (Marked.unmark ty) in
@ -313,11 +314,17 @@ and find_or_create_enum (ctx : context) (enum : EnumName.t) :
| Some e -> ctx, e
| None ->
let ctrs = EnumMap.find enum ctx.ctx_decl.ctx_enums in
let ctx, z3_ctrs = List.fold_left_map create_constructor ctx ctrs in
let ctx, z3_ctrs =
EnumConstructorMap.fold
(fun ctr ty (ctx, ctrs) ->
let ctx, ctr = create_constructor ctr ty ctx in
ctx, ctr :: ctrs)
ctrs (ctx, [])
in
let z3_enum =
Datatype.mk_sort_s ctx.ctx_z3
(Marked.unmark (EnumName.get_info enum))
z3_ctrs
(List.rev z3_ctrs)
in
add_z3enum enum z3_enum ctx, z3_enum
@ -337,13 +344,16 @@ and find_or_create_struct (ctx : context) (s : StructName.t) :
(fun f ->
Marked.unmark (StructFieldName.get_info (fst f))
|> Symbol.mk_string ctx.ctx_z3)
fields
(StructFieldMap.bindings fields)
in
let ctx, z3_fieldtypes =
List.fold_left_map
(fun ctx f -> Marked.unmark (snd f) |> translate_typ ctx)
ctx fields
let ctx, z3_fieldtypes_rev =
StructFieldMap.fold
(fun _ ty (ctx, ftypes) ->
let ctx, ftype = translate_typ ctx (Marked.unmark ty) in
ctx, ftype :: ftypes)
fields (ctx, [])
in
let z3_fieldtypes = List.rev z3_fieldtypes_rev in
let z3_sortrefs = List.map Sort.get_id z3_fieldtypes in
let mk_struct_s = "mk!" ^ s_name in
let z3_mk_struct =
@ -437,8 +447,11 @@ let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
| Binop bop -> (
(* Special case for GetYear comparisons *)
match bop, args with
| Lt KInt, [(EApp ((EOp (Unop GetYear), _), [e1]), _); (ELit (LInt n), _)]
->
| ( Lt KInt,
[
(EApp { f = EOp (Unop GetYear), _; args = [e1] }, _);
(ELit (LInt n), _);
] ) ->
let n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in
let e2 =
@ -449,8 +462,11 @@ let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
be directly translated as < in the Z3 encoding using the number of
days *)
ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2
| Lte KInt, [(EApp ((EOp (Unop GetYear), _), [e1]), _); (ELit (LInt n), _)]
->
| ( Lte KInt,
[
(EApp { f = EOp (Unop GetYear), _; args = [e1] }, _);
(ELit (LInt n), _);
] ) ->
let ctx, e1 = translate_expr ctx e1 in
let nb_days = if is_leap_year n then 365 else 364 in
let n = Runtime.integer_to_int n in
@ -463,8 +479,11 @@ let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
(date_to_int (date_of_year n) + nb_days)
in
ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2
| Gt KInt, [(EApp ((EOp (Unop GetYear), _), [e1]), _); (ELit (LInt n), _)]
->
| ( Gt KInt,
[
(EApp { f = EOp (Unop GetYear), _; args = [e1] }, _);
(ELit (LInt n), _);
] ) ->
let ctx, e1 = translate_expr ctx e1 in
let nb_days = if is_leap_year n then 365 else 364 in
let n = Runtime.integer_to_int n in
@ -477,8 +496,11 @@ let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
(date_to_int (date_of_year n) + nb_days)
in
ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2
| Gte KInt, [(EApp ((EOp (Unop GetYear), _), [e1]), _); (ELit (LInt n), _)]
->
| ( Gte KInt,
[
(EApp { f = EOp (Unop GetYear), _; args = [e1] }, _);
(ELit (LInt n), _);
] ) ->
let n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in
let e2 =
@ -489,7 +511,11 @@ let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
thus be directly translated as >= in the Z3 encoding using the number
of days *)
ctx, Arithmetic.mk_ge ctx.ctx_z3 e1 e2
| Eq, [(EApp ((EOp (Unop GetYear), _), [e1]), _); (ELit (LInt n), _)] ->
| ( Eq,
[
(EApp { f = EOp (Unop GetYear), _; args = [e1] }, _);
(ELit (LInt n), _);
] ) ->
let n = Runtime.integer_to_int n in
let ctx, e1 = translate_expr ctx e1 in
let min_date =
@ -562,7 +588,10 @@ let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
| Unop uop -> (
let ctx, e1 =
match args with
| [e1] -> translate_expr ctx e1
| [e1] -> (
try translate_expr ctx e1
with Z3.Error s ->
Errors.raise_spanned_error (Shared_ast.Expr.pos e1) "%s" s)
| _ ->
Format.kasprintf failwith
"[Z3 encoding] Ill-formed unary operator application: %a"
@ -624,7 +653,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
(e : 'm expr * FuncDecl.func_decl list) : context * Expr.expr =
let e, accessors = e in
match Marked.unmark e with
| EAbs (e, _) ->
| EAbs { binder; _ } ->
(* Create a fresh Catala variable to substitue and obtain the body *)
let fresh_v = Var.make "arm!tmp" in
let fresh_e = EVar fresh_v in
@ -636,7 +665,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
in the body, we add this to the context *)
let ctx = add_z3matchsubst fresh_v proj ctx in
let body = Bindlib.msubst e [| fresh_e |] in
let body = Bindlib.msubst binder [| fresh_e |] in
translate_expr ctx body
(* Invariant: Catala match arms are always lambda*)
| _ -> failwith "[Z3 encoding] : Arms branches inside VCs should be lambdas"
@ -670,32 +699,48 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
of a match. It actually corresponds to applying an accessor to an enum,
the corresponding Z3 expression was previously stored in the context *)
ctx, e)
| ETuple _ -> failwith "[Z3 encoding] ETuple unsupported"
| ETupleAccess (s, idx, oname, _tys) ->
let name =
match oname with
| None ->
failwith "[Z3 encoding]: ETupleAccess of unnamed struct unsupported"
| Some n -> n
in
| EStruct _ -> failwith "[Z3 encoding] EStruct unsupported"
| EStructAccess { e; field; name } ->
let ctx, z3_struct = find_or_create_struct ctx name in
(* This datatype should have only one constructor, corresponding to
mk_struct. The accessors of this constructor correspond to the field
accesses *)
let accessors = List.hd (Datatype.get_accessors z3_struct) in
let accessor = List.nth accessors idx in
let ctx, s = translate_expr ctx s in
let idx_mappings =
List.combine
(List.map fst
(StructFieldMap.bindings
(StructMap.find name ctx.ctx_decl.ctx_structs)))
accessors
in
let _, accessor =
List.find
(fun (field1, _) -> StructFieldName.equal field field1)
idx_mappings
in
let ctx, s = translate_expr ctx e in
ctx, Expr.mk_app ctx.ctx_z3 accessor [s]
| EInj (e, idx, en, _tys) ->
| EInj { e; cons; name } ->
(* This node corresponds to creating a value for the enumeration [en], by
calling the [idx]-th constructor of enum [en], with argument [e] *)
let ctx, z3_enum = find_or_create_enum ctx en in
let ctx, z3_enum = find_or_create_enum ctx name in
let ctx, z3_arg = translate_expr ctx e in
let ctrs = Datatype.get_constructors z3_enum in
(* This should always succeed if the expression is well-typed in dcalc *)
let ctr = List.nth ctrs idx in
let idx_mappings =
List.combine
(List.map fst
(EnumConstructorMap.bindings
(EnumMap.find name ctx.ctx_decl.ctx_enums)))
ctrs
in
let _, ctr =
List.find
(fun (cons1, _) -> EnumConstructor.equal cons cons1)
idx_mappings
in
ctx, Expr.mk_app ctx.ctx_z3 ctr [z3_arg]
| EMatch (arg, arms, enum) ->
| EMatch { e; cases; name = enum } ->
(* We will encode a match as a new variable, tmp_v, and add to the
hypotheses that this variable is equal to the conjunction of all `A? arg
==> tmp_v == body`, where `A? arg ==> body` is an arm of the match *)
@ -709,12 +754,14 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
let z3_var = Expr.mk_const_s ctx.ctx_z3 name z3_ty in
let ctx, z3_enum = find_or_create_enum ctx enum in
let ctx, z3_arg = translate_expr ctx arg in
let ctx, z3_arg = translate_expr ctx e in
let _ctx, z3_arms =
List.fold_left_map
(translate_match_arm z3_arg)
ctx
(List.combine arms (Datatype.get_accessors z3_enum))
(List.combine
(List.map snd (EnumConstructorMap.bindings cases))
(Datatype.get_accessors z3_enum))
in
let z3_arms =
List.map2
@ -733,7 +780,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
| EArray _ -> failwith "[Z3 encoding] EArray unsupported"
| ELit l -> ctx, translate_lit ctx l
| EAbs _ -> failwith "[Z3 encoding] EAbs unsupported"
| EApp (head, args) -> (
| EApp { f = head; args } -> (
match Marked.unmark head with
| EOp op -> translate_op ctx op args
| EVar v ->
@ -756,7 +803,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
| EAssert _ -> failwith "[Z3 encoding] EAssert unsupported"
| EOp _ -> failwith "[Z3 encoding] EOp unsupported"
| EDefault _ -> failwith "[Z3 encoding] EDefault unsupported"
| EIfThenElse (e_if, e_then, e_else) ->
| EIfThenElse { cond = e_if; etrue = e_then; efalse = e_else } ->
(* Encode this as (e_if ==> e_then) /\ (not e_if ==> e_else) *)
let ctx, z3_if = translate_expr ctx e_if in
let ctx, z3_then = translate_expr ctx e_then in
@ -769,7 +816,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
(Boolean.mk_not ctx.ctx_z3 z3_if)
z3_else;
] )
| ErrorOnEmpty _ -> failwith "[Z3 encoding] ErrorOnEmpty unsupported"
| EErrorOnEmpty _ -> failwith "[Z3 encoding] ErrorOnEmpty unsupported"
(** [create_z3unit] creates a Z3 sort and expression corresponding to the unit
type and value respectively. Concretely, we represent unit as a tuple with 0
@ -806,7 +853,7 @@ module Backend = struct
let print_model (ctx : backend_context) (m : model) : string =
print_model ctx m
let is_model_empty (m : model) : bool = List.length (Z3.Model.get_decls m) = 0
let is_model_empty (m : model) : bool = Z3.Model.get_decls m = []
let translate_expr (ctx : backend_context) (e : typed expr) =
translate_expr ctx e

3714
french_law/ocaml/law_source/aides_logement.ml generated
View File

File diff suppressed because it is too large Load Diff

93
french_law/ocaml/law_source/allocations_familiales.ml generated
View File

@ -403,26 +403,27 @@ let enfant_le_plus_age (enfant_le_plus_age_in: EnfantLePlusAgeIn.t) : EnfantLePl
start_line=12; start_column=14; end_line=12; end_column=25;
law_headings=["Règles diverses"; "Épilogue"]} true))
(fun (_: unit) ->
(let predicate_ : _ =
(fun (potentiel_plus_age_: _) ->
(let predicate_ : Enfant.t -> date =
(fun (potentiel_plus_age_: Enfant.t) ->
potentiel_plus_age_.Enfant.date_de_naissance)
in
(Array.fold_left
(fun (acc_: _) (item_: _) ->
(fun (acc_: Enfant.t) (item_: Enfant.t) ->
if ((predicate_ acc_) <@ (predicate_ item_)) then
acc_ else item_)
{Enfant.identifiant = (integer_of_string "-1");
Enfant.obligation_scolaire =
(SituationObligationScolaire.Pendant ());
Enfant.remuneration_mensuelle = (money_of_cents_string "0");
Enfant.date_de_naissance =
(date_of_numbers (2999) (12) (31));
Enfant.prise_en_charge =
(PriseEnCharge.EffectiveEtPermanente ());
Enfant.a_deja_ouvert_droit_aux_allocations_familiales =
false;
Enfant.beneficie_titre_personnel_aide_personnelle_logement =
false} enfants_))))
({Enfant.identifiant = (integer_of_string "-1");
Enfant.obligation_scolaire =
(SituationObligationScolaire.Pendant ());
Enfant.remuneration_mensuelle = (money_of_cents_string
"0");
Enfant.date_de_naissance =
(date_of_numbers (2999) (12) (31));
Enfant.prise_en_charge =
(PriseEnCharge.EffectiveEtPermanente ());
Enfant.a_deja_ouvert_droit_aux_allocations_familiales =
false;
Enfant.beneficie_titre_personnel_aide_personnelle_logement =
false}) enfants_))))
with
EmptyError -> (raise (NoValueProvided
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -872,8 +873,8 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
let result_: Smic.t = (log_end_call
["PrestationsFamiliales"; "smic"; "Smic"] ((log_begin_call
["PrestationsFamiliales"; "smic"; "Smic"] smic)
{SmicIn.date_courante_in = smic_dot_date_courante_;
SmicIn.residence_in = smic_dot_residence_})) in
({SmicIn.date_courante_in = smic_dot_date_courante_;
SmicIn.residence_in = smic_dot_residence_}))) in
let smic_dot_brut_horaire_: money = result_.Smic.brut_horaire in
let regime_outre_mer_l751_1_: bool = (log_variable_definition
["PrestationsFamiliales"; "régime_outre_mer_l751_1"] (embed_bool) (
@ -1614,7 +1615,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"AllocationFamilialesAvril2008"] ((log_begin_call
["AllocationsFamiliales"; "version_avril_2008";
"AllocationFamilialesAvril2008"] allocation_familiales_avril2008)
())) in
(()))) in
let version_avril_2008_dot_age_minimum_alinea_1_l521_3_: duration = result_.AllocationFamilialesAvril2008.age_minimum_alinea_1_l521_3 in
let bmaf_dot_date_courante_: date =
try ((log_variable_definition
@ -1641,8 +1642,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
((log_begin_call
["AllocationsFamiliales"; "bmaf"; "BaseMensuelleAllocationsFamiliales"]
base_mensuelle_allocations_familiales)
{BaseMensuelleAllocationsFamilialesIn.date_courante_in =
bmaf_dot_date_courante_})) in
({BaseMensuelleAllocationsFamilialesIn.date_courante_in =
bmaf_dot_date_courante_}))) in
let bmaf_dot_montant_: money = result_.BaseMensuelleAllocationsFamiliales.montant in
let prestations_familiales_dot_date_courante_: date =
try ((log_variable_definition
@ -1713,12 +1714,12 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"PrestationsFamiliales"] ((log_begin_call
["AllocationsFamiliales"; "prestations_familiales";
"PrestationsFamiliales"] prestations_familiales)
{PrestationsFamilialesIn.date_courante_in =
prestations_familiales_dot_date_courante_;
PrestationsFamilialesIn.prestation_courante_in =
prestations_familiales_dot_prestation_courante_;
PrestationsFamilialesIn.residence_in =
prestations_familiales_dot_residence_})) in
({PrestationsFamilialesIn.date_courante_in =
prestations_familiales_dot_date_courante_;
PrestationsFamilialesIn.prestation_courante_in =
prestations_familiales_dot_prestation_courante_;
PrestationsFamilialesIn.residence_in =
prestations_familiales_dot_residence_}))) in
let prestations_familiales_dot_droit_ouvert_: Enfant.t -> bool = result_.PrestationsFamiliales.droit_ouvert in
let prestations_familiales_dot_conditions_hors_age_: Enfant.t -> bool = result_.PrestationsFamiliales.conditions_hors_age in
let prestations_familiales_dot_age_l512_3_2_: duration = result_.PrestationsFamiliales.age_l512_3_2 in
@ -1746,7 +1747,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
((log_begin_call
["AllocationsFamiliales"; "enfant_le_plus_âgé"; "EnfantLePlusÂgé"]
enfant_le_plus_age)
{EnfantLePlusAgeIn.enfants_in = enfant_le_plus_age_dot_enfants_})) in
({EnfantLePlusAgeIn.enfants_in = enfant_le_plus_age_dot_enfants_}))) in
let enfant_le_plus_age_dot_le_plus_age_: Enfant.t = result_.EnfantLePlusAge.le_plus_age in
let age_minimum_alinea_1_l521_3_: Enfant.t -> duration = (log_variable_definition
["AllocationsFamiliales"; "âge_minimum_alinéa_1_l521_3"] (unembeddable)
@ -1826,7 +1827,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Code de la sécurité sociale"]} true))
(fun (_: unit) ->
array_filter
(fun (enfant_: _) -> (log_end_call
(fun (enfant_: Enfant.t) -> (log_end_call
["PrestationsFamiliales"; "droit_ouvert"]
((log_variable_definition
["PrestationsFamiliales"; "droit_ouvert"; "output"]
@ -2685,7 +2686,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Code de la sécurité sociale"]} true))
(fun (_: unit) ->
Array.fold_left
(fun (acc_: decimal) (enfant_: _) ->
(fun (acc_: decimal) (enfant_: Enfant.t) ->
acc_ +&
(match ((log_end_call
["AllocationsFamiliales"; "prise_en_compte"]
@ -4286,7 +4287,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
montant_verse_forfaitaire_par_enfant_ *$
(decimal_of_integer
(Array.fold_left
(fun (acc_: integer) (enfant_: _) ->
(fun (acc_: integer) (enfant_: Enfant.t) ->
if
((log_end_call
["AllocationsFamiliales";
@ -4750,7 +4751,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(fun (_: unit) ->
if droit_ouvert_base_ then
(Array.fold_left
(fun (acc_: money) (enfant_: _) ->
(fun (acc_: money) (enfant_: Enfant.t) ->
acc_ +$ ((log_end_call
["AllocationsFamiliales";
"montant_avec_garde_alternée_majoration"]
@ -4911,7 +4912,7 @@ let interface_allocations_familiales (interface_allocations_familiales_in: Inter
"Épilogue"]} true))
(fun (_: unit) ->
Array.map
(fun (enfant_: _) ->
(fun (enfant_: EnfantEntree.t) ->
{Enfant.identifiant = (enfant_.EnfantEntree.d_identifiant);
Enfant.obligation_scolaire =
( if
@ -5115,20 +5116,20 @@ let interface_allocations_familiales (interface_allocations_familiales_in: Inter
"AllocationsFamiliales"] ((log_begin_call
["InterfaceAllocationsFamiliales"; "allocations_familiales";
"AllocationsFamiliales"] allocations_familiales)
{AllocationsFamilialesIn.personne_charge_effective_permanente_est_parent_in =
allocations_familiales_dot_personne_charge_effective_permanente_est_parent_;
AllocationsFamilialesIn.personne_charge_effective_permanente_remplit_titre_I_in =
allocations_familiales_dot_personne_charge_effective_permanente_remplit_titre__i_;
AllocationsFamilialesIn.ressources_menage_in =
allocations_familiales_dot_ressources_menage_;
AllocationsFamilialesIn.residence_in =
allocations_familiales_dot_residence_;
AllocationsFamilialesIn.date_courante_in =
allocations_familiales_dot_date_courante_;
AllocationsFamilialesIn.enfants_a_charge_in =
allocations_familiales_dot_enfants_a_charge_;
AllocationsFamilialesIn.avait_enfant_a_charge_avant_1er_janvier_2012_in =
allocations_familiales_dot_avait_enfant_a_charge_avant_1er_janvier_2012_})) in
({AllocationsFamilialesIn.personne_charge_effective_permanente_est_parent_in =
allocations_familiales_dot_personne_charge_effective_permanente_est_parent_;
AllocationsFamilialesIn.personne_charge_effective_permanente_remplit_titre_I_in =
allocations_familiales_dot_personne_charge_effective_permanente_remplit_titre__i_;
AllocationsFamilialesIn.ressources_menage_in =
allocations_familiales_dot_ressources_menage_;
AllocationsFamilialesIn.residence_in =
allocations_familiales_dot_residence_;
AllocationsFamilialesIn.date_courante_in =
allocations_familiales_dot_date_courante_;
AllocationsFamilialesIn.enfants_a_charge_in =
allocations_familiales_dot_enfants_a_charge_;
AllocationsFamilialesIn.avait_enfant_a_charge_avant_1er_janvier_2012_in =
allocations_familiales_dot_avait_enfant_a_charge_avant_1er_janvier_2012_}))) in
let allocations_familiales_dot_montant_verse_: money = result_.AllocationsFamiliales.montant_verse in
let i_montant_verse_: money = (log_variable_definition
["InterfaceAllocationsFamiliales"; "i_montant_versé"] (embed_money) (

38
french_law/python/src/aides_logement.py generated
View File

@ -2805,7 +2805,7 @@ def calcul_equivalence_loyer_minimale(calcul_equivalence_loyer_minimale_in:Calcu
"Prologue : aides au logement"]))
tranches_revenus_d832_26 = temp_tranches_revenus_d832_26
try:
def temp_tranches_revenus_d832_26_multipliees(tranche:Any):
def temp_tranches_revenus_d832_26_multipliees(tranche:TrancheRevenu):
match_arg = tranche.haut
if match_arg.code == LimiteTranche_Code.Revenu:
tranche_haut = match_arg.value
@ -2834,7 +2834,7 @@ def calcul_equivalence_loyer_minimale(calcul_equivalence_loyer_minimale_in:Calcu
try:
try:
if condition_2_du_832_25:
def temp_montant_1(acc:Decimal, tranche_1:Any):
def temp_montant_1(acc:Decimal, tranche_1:TrancheRevenuDecimal):
if (decimal_of_money(ressources_menage_arrondies) <=
tranche_1.bas):
temp_montant_2 = decimal_of_string("0.")
@ -2863,7 +2863,7 @@ def calcul_equivalence_loyer_minimale(calcul_equivalence_loyer_minimale_in:Calcu
temp_montant_3 = dead_value
raise EmptyError
except EmptyError:
def temp_montant_4(acc_1:Decimal, tranche_2:Any):
def temp_montant_4(acc_1:Decimal, tranche_2:TrancheRevenuDecimal):
if (decimal_of_money(ressources_menage_arrondies) <=
tranche_2.bas):
temp_montant_5 = decimal_of_string("0.")
@ -11225,7 +11225,7 @@ def eligibilite_aides_personnelle_logement(eligibilite_aides_personnelle_logemen
temp_patrimoine_pris_en_compte = dead_value
raise EmptyError
except EmptyError:
def temp_patrimoine_pris_en_compte_1(acc_2:bool, prestation:Any):
def temp_patrimoine_pris_en_compte_1(acc_2:bool, prestation:PrestationRecue):
return (acc_2 or ((prestation ==
PrestationRecue(PrestationRecue_Code.AllocationSoutienEnfantHandicape,
Unit())) or (prestation ==
@ -11436,7 +11436,7 @@ def eligibilite_aides_personnelle_logement(eligibilite_aides_personnelle_logemen
"Prologue : aides au logement"]))
prise_en_compte_personne_a_charge = temp_prise_en_compte_personne_a_charge
try:
def temp_personnes_a_charge_prises_en_compte(personne_a_charge:Any):
def temp_personnes_a_charge_prises_en_compte(personne_a_charge:PersonneACharge):
return prise_en_compte_personne_a_charge(personne_a_charge)
temp_personnes_a_charge_prises_en_compte_1 = list_filter(temp_personnes_a_charge_prises_en_compte,
menage.personnes_a_charge)
@ -11450,7 +11450,7 @@ def eligibilite_aides_personnelle_logement(eligibilite_aides_personnelle_logemen
"Prologue : aides au logement"]))
personnes_a_charge_prises_en_compte = temp_personnes_a_charge_prises_en_compte_1
try:
def temp_coefficents_enfants_garde_alternee_pris_en_compte(personne_a_charge_1:Any):
def temp_coefficents_enfants_garde_alternee_pris_en_compte(personne_a_charge_1:PersonneACharge):
match_arg_371 = personne_a_charge_1
if match_arg_371.code == PersonneACharge_Code.EnfantACharge:
enfant_3 = match_arg_371.value
@ -11464,7 +11464,7 @@ def eligibilite_aides_personnelle_logement(eligibilite_aides_personnelle_logemen
elif match_arg_371.code == PersonneACharge_Code.AutrePersonneACharge:
_ = match_arg_371.value
return False
def temp_coefficents_enfants_garde_alternee_pris_en_compte_1(personne_a_charge_2:Any):
def temp_coefficents_enfants_garde_alternee_pris_en_compte_1(personne_a_charge_2:PersonneACharge):
match_arg_373 = personne_a_charge_2
if match_arg_373.code == PersonneACharge_Code.EnfantACharge:
enfant_4 = match_arg_373.value
@ -11608,7 +11608,7 @@ def ressources_aides_personnelle_logement(ressources_aides_personnelle_logement_
"Prologue : aides au logement"]))
ressources_forfaitaires_r822_20 = temp_ressources_forfaitaires_r822_20
try:
def temp_ressources_personnes_vivant_habituellement_foyer(acc_3:Money, personne_1:Any):
def temp_ressources_personnes_vivant_habituellement_foyer(acc_3:Money, personne_1:PersonneVivantHabituellementAuFoyer):
return (acc_3 + personne_1.ressources)
temp_ressources_personnes_vivant_habituellement_foyer_1 = list_fold_left(
temp_ressources_personnes_vivant_habituellement_foyer,
@ -11777,7 +11777,7 @@ def ressources_aides_personnelle_logement(ressources_aides_personnelle_logement_
"Prologue : aides au logement"]))
abattement_r_822_7 = temp_abattement_r_822_7
try:
def temp___5(acc_4:bool, personne_2:Any):
def temp___5(acc_4:bool, personne_2:PersonneVivantHabituellementAuFoyer):
return (acc_4 and
personne_2.duree_residence_durant_periode_r_822_3_1_superieure_a_6_mois)
temp___6 = list_fold_left(temp___5, True,
@ -17951,7 +17951,7 @@ def eligibilite_prime_de_demenagement(eligibilite_prime_de_demenagement_in:Eligi
delai_apres_emmenagement_l823_8_2 = temp_delai_apres_emmenagement_l823_8_2
try:
try:
def temp_condition_rang_enfant(acc_5:Integer, personne_a_charge_3:Any):
def temp_condition_rang_enfant(acc_5:Integer, personne_a_charge_3:PersonneACharge):
match_arg_506 = personne_a_charge_3
if match_arg_506.code == PersonneACharge_Code.EnfantACharge:
_ = match_arg_506.value
@ -18087,7 +18087,7 @@ def eligibilite_prime_de_demenagement(eligibilite_prime_de_demenagement_in:Eligi
"Prologue : aides au logement"]))
condition_periode_demenagement = temp_condition_periode_demenagement_1
try:
def temp_plafond_d823_22(acc_6:Integer, personne_a_charge_4:Any):
def temp_plafond_d823_22(acc_6:Integer, personne_a_charge_4:PersonneACharge):
match_arg_509 = personne_a_charge_4
if match_arg_509.code == PersonneACharge_Code.EnfantACharge:
_ = match_arg_509.value
@ -18102,7 +18102,7 @@ def eligibilite_prime_de_demenagement(eligibilite_prime_de_demenagement_in:Eligi
if (list_fold_left(temp_plafond_d823_22, integer_of_string("0"),
menage_1.personnes_a_charge) >
integer_of_string("3")):
def temp_plafond_d823_22_2(acc_7:Integer, personne_a_charge_5:Any):
def temp_plafond_d823_22_2(acc_7:Integer, personne_a_charge_5:PersonneACharge):
match_arg_510 = personne_a_charge_5
if match_arg_510.code == PersonneACharge_Code.EnfantACharge:
_ = match_arg_510.value
@ -19037,7 +19037,7 @@ def eligibilite_allocation_logement(eligibilite_allocation_logement_in:Eligibili
raise EmptyError
except EmptyError:
try:
def temp_eligibilite_allocation_logement_familiale_2(acc_8:Integer, personne_a_charge_6:Any):
def temp_eligibilite_allocation_logement_familiale_2(acc_8:Integer, personne_a_charge_6:PersonneACharge):
match_arg_541 = personne_a_charge_6
if match_arg_541.code == PersonneACharge_Code.EnfantACharge:
enfant_5 = match_arg_541.value
@ -19060,7 +19060,7 @@ def eligibilite_allocation_logement(eligibilite_allocation_logement_in:Eligibili
temp_eligibilite_allocation_logement_familiale_1 = dead_value
raise EmptyError
except EmptyError:
def temp_eligibilite_allocation_logement_familiale_4(acc_9:Integer, personne_a_charge_7:Any):
def temp_eligibilite_allocation_logement_familiale_4(acc_9:Integer, personne_a_charge_7:PersonneACharge):
if eligibilite_commune_dot_condition_2_r823_4_1(
personne_a_charge_7):
return (acc_9 +
@ -19096,7 +19096,7 @@ def eligibilite_allocation_logement(eligibilite_allocation_logement_in:Eligibili
elif match_arg_542.code == SituationFamiliale_Code.ConcubinageDontSepareDeFait:
_ = match_arg_542.value
temp_eligibilite_allocation_logement_familiale_5 = False
def temp_eligibilite_allocation_logement_familiale_6(acc_10:Integer, personne_a_charge_8:Any):
def temp_eligibilite_allocation_logement_familiale_6(acc_10:Integer, personne_a_charge_8:PersonneACharge):
match_arg_543 = personne_a_charge_8
if match_arg_543.code == PersonneACharge_Code.EnfantACharge:
enfant_6 = match_arg_543.value
@ -19134,7 +19134,7 @@ def eligibilite_allocation_logement(eligibilite_allocation_logement_in:Eligibili
temp_eligibilite_allocation_logement_familiale_1 = dead_value
raise EmptyError
except EmptyError:
def temp_eligibilite_allocation_logement_familiale_9(acc_11:Integer, personne_a_charge_9:Any):
def temp_eligibilite_allocation_logement_familiale_9(acc_11:Integer, personne_a_charge_9:PersonneACharge):
match_arg_545 = personne_a_charge_9
if match_arg_545.code == PersonneACharge_Code.EnfantACharge:
enfant_7 = match_arg_545.value
@ -19171,7 +19171,7 @@ def eligibilite_allocation_logement(eligibilite_allocation_logement_in:Eligibili
temp_eligibilite_allocation_logement_familiale_1 = dead_value
raise EmptyError
except EmptyError:
def temp_eligibilite_allocation_logement_familiale_12(acc_12:bool, prestation_1:Any):
def temp_eligibilite_allocation_logement_familiale_12(acc_12:bool, prestation_1:PrestationRecue):
return (acc_12 or ((prestation_1 ==
PrestationRecue(PrestationRecue_Code.AllocationsFamiliales,
Unit())) or ((prestation_1 ==
@ -22034,7 +22034,7 @@ def calculette_aides_au_logement_garde_alternee(calculette_aides_au_logement_gar
date_courante_17 = calculette_aides_au_logement_garde_alternee_in.date_courante_in
ressources_menage_prises_en_compte_1 = calculette_aides_au_logement_garde_alternee_in.ressources_menage_prises_en_compte_in
try:
def temp_menage_sans_enfants_garde_alternee(personne_a_charge_10:Any):
def temp_menage_sans_enfants_garde_alternee(personne_a_charge_10:PersonneACharge):
match_arg_559 = personne_a_charge_10
if match_arg_559.code == PersonneACharge_Code.EnfantACharge:
enfant_8 = match_arg_559.value
@ -22195,7 +22195,7 @@ def calculette_aides_au_logement_garde_alternee(calculette_aides_au_logement_gar
integer_of_string("0")):
temp_aide_finale = money_of_cents_string("0")
else:
def temp_aide_finale_1(acc_13:Decimal, coeff_1:Any):
def temp_aide_finale_1(acc_13:Decimal, coeff_1:Decimal):
return (acc_13 + coeff_1)
temp_aide_finale = ((calculette_dot_aide_finale_formule -
calculette_sans_garde_alternee_dot_aide_finale_formule) *

12
french_law/python/src/allocations_familiales.py generated
View File

@ -514,7 +514,7 @@ def allocation_familiales_avril2008(allocation_familiales_avril2008_in:Allocatio
def enfant_le_plus_age(enfant_le_plus_age_in:EnfantLePlusAgeIn):
enfants = enfant_le_plus_age_in.enfants_in
try:
def temp_le_plus_age(acc:Any, item:Any):
def temp_le_plus_age(acc:Enfant, item:Enfant):
if (acc.date_de_naissance < item.date_de_naissance):
return acc
else:
@ -1411,7 +1411,7 @@ def allocations_familiales(allocations_familiales_in:AllocationsFamilialesIn):
"Prologue"]))
age_minimum_alinea_1_l521_3_1 = temp_age_minimum_alinea_1_l521_3_1
try:
def temp_enfants_a_charge_droit_ouvert_prestation_familiale(enfant:Any):
def temp_enfants_a_charge_droit_ouvert_prestation_familiale(enfant:Enfant):
return prestations_familiales_dot_droit_ouvert(enfant)
temp_enfants_a_charge_droit_ouvert_prestation_familiale_1 = list_filter(temp_enfants_a_charge_droit_ouvert_prestation_familiale,
enfants_a_charge)
@ -1846,7 +1846,7 @@ def allocations_familiales(allocations_familiales_in:AllocationsFamilialesIn):
"Prologue"]))
nombre_total_enfants = temp_nombre_total_enfants
try:
def temp_nombre_moyen_enfants(acc_1:Decimal, enfant_1:Any):
def temp_nombre_moyen_enfants(acc_1:Decimal, enfant_1:Enfant):
match_arg_16 = prise_en_compte(enfant_1)
if match_arg_16.code == PriseEnCompte_Code.Complete:
_ = match_arg_16.value
@ -2637,7 +2637,7 @@ def allocations_familiales(allocations_familiales_in:AllocationsFamilialesIn):
"Prologue"]))
montant_initial_metropole_majoration = temp_montant_initial_metropole_majoration
try:
def temp_montant_verse_forfaitaire(acc_2:Integer, enfant_2:Any):
def temp_montant_verse_forfaitaire(acc_2:Integer, enfant_2:Enfant):
if droit_ouvert_forfaitaire(enfant_2):
return (acc_2 + integer_of_string("1"))
else:
@ -2872,7 +2872,7 @@ def allocations_familiales(allocations_familiales_in:AllocationsFamilialesIn):
montant_verse_base = temp_montant_verse_base
try:
if droit_ouvert_base:
def temp_montant_verse_majoration(acc_3:Money, enfant_3:Any):
def temp_montant_verse_majoration(acc_3:Money, enfant_3:Enfant):
return (acc_3 +
montant_avec_garde_alternee_majoration(enfant_3))
temp_montant_verse_majoration_1 = list_fold_left(temp_montant_verse_majoration,
@ -2969,7 +2969,7 @@ def interface_allocations_familiales(interface_allocations_familiales_in:Interfa
i_personne_charge_effective_permanente_remplit_titre__i = interface_allocations_familiales_in.i_personne_charge_effective_permanente_remplit_titre_I_in
i_avait_enfant_a_charge_avant_1er_janvier_2012 = interface_allocations_familiales_in.i_avait_enfant_a_charge_avant_1er_janvier_2012_in
try:
def temp_enfants_a_charge(enfant_4:Any):
def temp_enfants_a_charge(enfant_4:EnfantEntree):
if ((enfant_4.d_date_de_naissance +
duration_of_numbers(3,0,0)) >=
i_date_courante):

4
syntax_highlighting/emacs/catala-mode.el
View File

@ -22,7 +22,7 @@
(define-generic-mode 'catala-mode-fr
'("#")
'("contexte" "entrée" "sortie" "interne"
"champ d'application" "si et seulement si" "dépend de" "déclaration" "inclus" "collection" "contenu" "optionnel" "structure" "énumération" "contexte" "entrée" "sortie" "interne" "règle" "sous condition" "condition" "donnée" "conséquence" "rempli" "égal à" "assertion" "définition" "état" "étiquette" "exception")
"champ d'application" "si et seulement si" "dépend de" "déclaration" "inclus" "collection" "contenu" "optionnel" "structure" "énumération" "contexte" "entrée" "sortie" "interne" "règle" "sous condition" "condition" "donnée" "conséquence" "rempli" "égal à" "assertion" "définition" "état" "étiquette" "exception" "soit")
'(("\\<\\(selon\\|sous\s+forme\\|fixé\\|par\\|décroissante\\|croissante\\|varie\\|avec\\|on\s+a\\|soit\\|dans\\|tel\s+que\\|existe\\|pour\\|tout\\|de\\|si\\|alors\\|sinon\\|initial\\)\\>" . font-lock-builtin-face)
("\\<\\(vrai\\|faux\\)\\>" . font-lock-constant-face)
("\\<\\([0-9][0-9 ]*\\(,[0-9]*\\|\\)\\)\\>" . font-lock-constant-face)
@ -41,7 +41,7 @@
(define-generic-mode 'catala-mode-en
'("#")
'("context" "input" "output" "internal"
"scope" "depends on" "declaration" "includes" "collection" "content" "optional" "structure" "enumeration" "context" "input" "output" "internal" "rule" "under condition" "condition" "data" "consequence" "fulfilled" "equals" "assertion" "definition" "state" "label" "exception")
"scope" "depends on" "declaration" "includes" "collection" "content" "optional" "structure" "enumeration" "context" "input" "output" "internal" "rule" "under condition" "condition" "data" "consequence" "fulfilled" "equals" "assertion" "definition" "state" "label" "exception" "let")
'(("\\<\\(match\\|with\s+pattern\\|fixed\\|by\\|decreasing\\|increasing\\|varies\\|with\\|we\s+have\\|let\\|in\\|such\s+that\\|exists\\|for\\|all\\|of\\|if\\|then\\|else\\|initial\\)\\>" . font-lock-builtin-face)
("|[0-9]\\+-[0-9]\\+-[0-9]\\+|" . font-lock-constant-face)
("\\<\\(true\\|false\\)\\>" . font-lock-constant-face)

8
tests/test_array/good/aggregation_2.catala_en
View File

@ -29,13 +29,13 @@ scope B:
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] x =
[S {"id"= 0; "income"= $0.00}; S {"id"= 1; "income"= $9.00};
S {"id"= 2; "income"= $5.20}]
[S { "id"= 0; "income"= $0.00 }; S { "id"= 1; "income"= $9.00 };
S { "id"= 2; "income"= $5.20 }]
```
```catala-test-inline
$ catala Interpret -s B
[RESULT] Computation successful! Results:
[RESULT] argmax = S {"id"= 1; "income"= $9.00}
[RESULT] argmin = S {"id"= 0; "income"= $0.00}
[RESULT] argmax = S { "id"= 1; "income"= $9.00 }
[RESULT] argmin = S { "id"= 0; "income"= $0.00 }
```

2
tests/test_bool/good/test_bool.catala_en
View File

@ -26,7 +26,7 @@ let TestBool :
⟨foo () | true ⊢
⟨⟨bar1 >= 0 ⊢ true⟩, ⟨bar1 < 0 ⊢ false⟩ | false ⊢
∅ ⟩⟩ in
TestBool {"foo"= foo1; "bar"= bar1} in
TestBool { "foo"= foo1; "bar"= bar1 } in
TestBool
```

2
tests/test_exception/good/grouped_exceptions.catala_en
View File

@ -50,5 +50,5 @@ scope Benefit:
$ catala Interpret -s Benefit
[RESULT] Computation successful! Results:
[RESULT] benefit = $2000.00
[RESULT] person = Person {"age"= 26; "disabled"= true}
[RESULT] person = Person { "age"= 26; "disabled"= true }
```

2
tests/test_io/good/all_io.catala_en
View File

@ -32,7 +32,7 @@ let A =
⟨e () | true ⊢ ⟨true ⊢ b + c + d + 1⟩⟩ in
let f1 : integer = error_empty
⟨f () | true ⊢ ⟨true ⊢ e1 + 1⟩⟩ in
A {"b"= b; "d"= d; "f"= f1}
A { "b"= b; "d"= d; "f"= f1 }
```
```catala-test-inline

4
tests/test_io/good/condition_only_input.catala_en
View File

@ -19,10 +19,10 @@ $ catala Dcalc -s B
let B =
λ (B_in: B_in {}) →
let a.x : bool = error_empty ⟨true ⊢ false⟩ in
let result : A {"y": integer} = A (A_in {"x_in"= a.x}) in
let result : A {"y": integer} = A (A_in { "x_in"= a.x }) in
let a.y : integer = result."y" in
let _ : unit = assert (error_empty a.y = 1) in
B {}
B { }
```
```catala-test-inline

4
tests/test_io/good/subscope.catala_en
View File

@ -26,10 +26,10 @@ let B =
λ (B_in: B_in {}) →
let a.a : unit → integer = λ (_: unit) → ∅ in
let a.b : integer = error_empty ⟨true ⊢ 2⟩ in
let result : A {"c": integer} = A (A_in {"a_in"= a.a; "b_in"= a.b}) in
let result : A {"c": integer} = A (A_in { "a_in"= a.a; "b_in"= a.b }) in
let a.c : integer = result."c" in
let _ : unit = assert (error_empty a.c = 1) in
B {}
B { }
```
```catala-test-inline

4
tests/test_name_resolution/good/let_in.catala_en
View File

@ -28,8 +28,8 @@ scope S:
```catala-test-inline
$ catala Interpret -s S
[RESULT] Computation successful! Results:
[RESULT] a = A {"x"= -2.; "y"= B {"y"= false; "z"= -1.}}
[RESULT] b = B {"y"= true; "z"= 42.}
[RESULT] a = A { "x"= -2.; "y"= B { "y"= false; "z"= -1. } }
[RESULT] b = B { "y"= true; "z"= 42. }
```
## Check scope of let-in vs scope variable

4
tests/test_name_resolution/good/out_of_order.catala_en
View File

@ -21,6 +21,6 @@ scope S:
```catala-test-inline
$ catala Interpret -s S
[RESULT] Computation successful! Results:
[RESULT] a = A {"x"= 0; "y"= B {"y"= true; "z"= 0.}}
[RESULT] b = B {"y"= true; "z"= 0.}
[RESULT] a = A { "x"= 0; "y"= B { "y"= true; "z"= 0. } }
[RESULT] b = B { "y"= true; "z"= 0. }
```

2
tests/test_scope/good/191_fix_record_name_confusion.catala_en
View File

@ -66,7 +66,7 @@ let scope_a (scope_a_in: ScopeAIn.t) : ScopeA.t =
let scope_b (scope_b_in: ScopeBIn.t) : ScopeB.t =
let a_: unit -> bool = scope_b_in.ScopeBIn.a_in in
let scope_a_dot_a_: unit -> bool = fun (_: unit) -> (raise EmptyError) in
let result_: ScopeA.t = ((scope_a) {ScopeAIn.a_in = scope_a_dot_a_}) in
let result_: ScopeA.t = ((scope_a) ({ScopeAIn.a_in = scope_a_dot_a_})) in
let scope_a_dot_a_: bool = result_.ScopeA.a in
let a_: bool = (
try

10
tests/test_scope/good/nothing.catala_en
View File

@ -7,11 +7,11 @@ declaration scope Foo2:
```catala-test-inline
$ catala Scalc -s Foo2 -O -t
let Foo2 (Foo2_in : Foo2_in {}) =
decl temp_bar : any;
temp_bar = dead_value_1;
let Foo2 (Foo2_in_2 : Foo2_in {}) =
decl temp_bar_4 : any;
temp_bar_4 = dead_value_1;
raise NoValueProvided;
decl bar : integer;
bar = temp_bar_4;
decl bar_3 : integer;
bar_3 = temp_bar_4;
return Foo2 {"bar": bar_3}
```

4
tests/test_scope/good/scope_call2.catala_en
View File

@ -21,6 +21,6 @@ scope Titi:
```catala-test-inline
$ catala Interpret -s Titi
[RESULT] Computation successful! Results:
[RESULT] fizz = Toto {"foo"= 1213}
[RESULT] fuzz = Toto {"foo"= 1323}
[RESULT] fizz = Toto { "foo"= 1213 }
[RESULT] fuzz = Toto { "foo"= 1323 }
```

2
tests/test_scope/good/simple.catala_en
View File

@ -15,5 +15,5 @@ let Foo =
let bar : integer =
try handle_default [] (λ (_: unit) → true) (λ (_: unit) → 0) with
EmptyError -> raise NoValueProvided in
Foo {"bar"= bar}
Foo { "bar"= bar }
```

6
tests/test_struct/good/nested3.catala_en
View File

@ -37,12 +37,14 @@ scope B:
```catala-test-inline
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] t = T {"a"= S {"x"= 0; "y"= false}; "b"= S {"x"= 1; "y"= true}}
[RESULT] t =
T { "a"= S { "x"= 0; "y"= false }; "b"= S { "x"= 1; "y"= true } }
```
```catala-test-inline
$ catala Interpret -s B
[RESULT] Computation successful! Results:
[RESULT] out = 1
[RESULT] t = T {"a"= S {"x"= 0; "y"= false}; "b"= S {"x"= 1; "y"= true}}
[RESULT] t =
T { "a"= S { "x"= 0; "y"= false }; "b"= S { "x"= 1; "y"= true } }
```

2
tests/test_struct/good/same_name_fields.catala_en
View File

@ -19,6 +19,6 @@ scope A:
```catala-test-inline
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] x = Foo {"f"= 1}
[RESULT] x = Foo { "f"= 1 }
[RESULT] y = 1
```

2
tests/test_struct/good/simple.catala_en
View File

@ -20,6 +20,6 @@ scope A:
```catala-test-inline
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] s = S {"x"= 1; "y"= 2}
[RESULT] s = S { "x"= 1; "y"= 2 }
[RESULT] z = 3
```