- let t_magic = [p_base, 0; p_rec, 1] in
- let compiled = compiler t_magic in
- (fun term env ->
- let rec aux term =
- match compiled term with
- | None -> None
- | Some (env', 0) -> Some (env', [])
- | Some (env', 1) ->
- begin
- let acc = Env.lookup_term env' acc_name in
- let env'' = Env.remove env' acc_name in
- match aux acc with
- | None -> None
- | Some (base_env, rec_envl) ->
- Some (base_env, env'' :: rec_envl )
- end
- | _ -> assert false
- in
- match aux term with
- | None -> None
- | Some (base_env, rec_envl) ->
- Some (base_env @ Env.coalesce_env p_rec_decls rec_envl))
+ let compiled_base = compiler [p_base, 0]
+ and compiled_rec = compiler [p_rec, 0] in
+ (fun term env ctors ->
+ let aux_base term =
+ match compiled_base term with
+ | None -> None
+ | Some (env', ctors', _) -> Some (env', ctors', [])
+ in
+ let rec aux term =
+ match compiled_rec term with
+ | None -> aux_base term
+ | Some (env', ctors', _) ->
+ begin
+ let acc = Env.lookup_term env' acc_name in
+ let env'' = Env.remove_name env' acc_name in
+ match aux acc with
+ | None -> aux_base term
+ | Some (base_env, ctors', rec_envl) ->
+ let ctors'' = ctors' @ ctors in
+ Some (base_env, ctors'',env'' :: rec_envl)
+ end
+ in
+ match aux term with
+ | None -> None
+ | Some (base_env, ctors, rec_envl) ->
+ let env' =
+ base_env @ Env.coalesce_env p_rec_decls rec_envl @ env
+ (* @ env LUCA!!! *)
+ in
+ Some (env', ctors))
+
+ | Ast.Default (p_some, p_none) -> (* p_none can't bound names *)
+ let p_some_decls = Env.declarations_of_term p_some in
+ let p_none_decls = Env.declarations_of_term p_none in
+ let p_opt_decls =
+ List.filter
+ (fun decl -> not (List.mem decl p_none_decls))
+ p_some_decls
+ in
+ let none_env = List.map Env.opt_binding_of_name p_opt_decls in
+ let compiled = compiler [p_some, 0] in
+ (fun term env ctors ->
+ match compiled term with
+ | None -> Some (none_env, ctors) (* LUCA: @ env ??? *)
+ | Some (env', ctors', 0) ->
+ let env' =
+ List.map
+ (fun (name, (ty, v)) as binding ->
+ if List.exists (fun (name', _) -> name = name') p_opt_decls
+ then Env.opt_binding_some binding
+ else binding)
+ env'
+ in
+ Some (env' @ env, ctors' @ ctors)
+ | _ -> assert false)
+
+ | Ast.If (p_test, p_true, p_false) ->
+ let compiled_test = compiler [p_test, 0]
+ and compiled_true = compiler [p_true, 0]
+ and compiled_false = compiler [p_false, 0] in
+ (fun term env ctors ->
+ let branch =
+ match compiled_test term with
+ | None -> compiled_false
+ | Some _ -> compiled_true
+ in
+ match branch term with
+ | None -> None
+ | Some (env', ctors', _) -> Some (env' @ env, ctors' @ ctors))
+
+ | Ast.Fail -> (fun _ _ _ -> None)
+