Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit 48c29c43 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

keep user-supplied projections in algebraic types

parent 8ff52ea6
......@@ -13,6 +13,8 @@ transformation "eliminate_non_struct_recursion"
transformation "eliminate_if"
transformation "eliminate_projections"
transformation "simplify_formula"
(*transformation "simplify_trivial_quantification_in_goal"*)
......@@ -96,7 +98,7 @@ end
(* removed: Coq Zdiv is NOT true Euclidean division:
Zmod can be negative, in fact (Zmod x y) has the same sign as y,
which is not the usual convention of programming language either.
which is not the usual convention of programming language either.
theory int.EuclideanDivision
......
......@@ -15,6 +15,7 @@ transformation "eliminate_non_struct_recursion"
(* PVS only has simple patterns *)
transformation "compile_match"
transformation "eliminate_projections"
transformation "simplify_formula"
......
......@@ -25,9 +25,12 @@ open Term
(** Type declaration *)
type constructor = lsymbol * lsymbol option list
(** constructor symbol with the list of projections *)
type ty_defn =
| Tabstract
| Talgebraic of lsymbol list
| Talgebraic of constructor list
type ty_decl = tysymbol * ty_defn
......@@ -319,9 +322,12 @@ module Hsdecl = Hashcons.Make (struct
type t = decl
let cs_equal (cs1,pl1) (cs2,pl2) =
ls_equal cs1 cs2 && list_all2 (option_eq ls_equal) pl1 pl2
let eq_td (ts1,td1) (ts2,td2) = ts_equal ts1 ts2 && match td1,td2 with
| Tabstract, Tabstract -> true
| Talgebraic l1, Talgebraic l2 -> list_all2 ls_equal l1 l2
| Talgebraic l1, Talgebraic l2 -> list_all2 cs_equal l1 l2
| _ -> false
let eq_ld (ls1,ld1) (ls2,ld2) = ls_equal ls1 ls2 && match ld1,ld2 with
......@@ -343,9 +349,12 @@ module Hsdecl = Hashcons.Make (struct
k1 = k2 && pr_equal pr1 pr2 && t_equal f1 f2
| _,_ -> false
let cs_hash (cs,pl) =
Hashcons.combine_list (Hashcons.combine_option ls_hash) (ls_hash cs) pl
let hs_td (ts,td) = match td with
| Tabstract -> ts_hash ts
| Talgebraic l -> 1 + Hashcons.combine_list ls_hash (ts_hash ts) l
| Talgebraic l -> 1 + Hashcons.combine_list cs_hash (ts_hash ts) l
let hs_ld (ls,ld) = Hashcons.combine (ls_hash ls)
(Hashcons.combine_option (fun (_,f) -> t_hash f) ld)
......@@ -392,6 +401,11 @@ let mk_decl node syms news = Hsdecl.hashcons {
exception IllegalTypeAlias of tysymbol
exception ClashIdent of ident
exception BadLogicDecl of lsymbol * lsymbol
exception BadConstructor of lsymbol
exception BadRecordField of lsymbol
exception RecordFieldMissing of lsymbol
exception DuplicateRecordField of lsymbol
exception EmptyDecl
exception EmptyAlgDecl of tysymbol
......@@ -411,8 +425,21 @@ let create_ty_decl tdl =
if tdl = [] then raise EmptyDecl;
let add s (ts,_) = Sts.add ts s in
let tss = List.fold_left add Sts.empty tdl in
let check_constr tys ty (syms,news) fs =
ty_equal_check ty (of_option fs.ls_value);
let check_proj tyv s tya ls = match ls with
| None -> s
| Some ({ ls_args = [ptyv]; ls_value = Some ptya } as ls) ->
ty_equal_check tyv ptyv;
ty_equal_check tya ptya;
Sls.add_new (DuplicateRecordField ls) ls s
| Some ls -> raise (BadRecordField ls)
in
let check_constr tys ty pjs (syms,news) (fs,pl) =
ty_equal_check ty (exn_option (BadConstructor fs) fs.ls_value);
let fs_pjs =
try List.fold_left2 (check_proj ty) Sls.empty fs.ls_args pl
with Invalid_argument _ -> raise (BadConstructor fs) in
if not (Sls.equal pjs fs_pjs) then
raise (RecordFieldMissing (Sls.choose (Sls.diff pjs fs_pjs)));
let vs = ty_freevars Stv.empty ty in
let rec check seen ty = match ty.ty_node with
| Tyvar v when Stv.mem v vs -> ()
......@@ -435,8 +462,11 @@ let create_ty_decl tdl =
if cl = [] then raise (EmptyAlgDecl ts);
if ts.ts_def <> None then raise (IllegalTypeAlias ts);
let news = news_id news ts.ts_name in
let pjs = List.fold_left (fun s (_,pl) -> List.fold_left
(option_fold (fun s ls -> Sls.add ls s)) s pl) Sls.empty cl in
let news = Sls.fold (fun pj s -> news_id s pj.ls_name) pjs news in
let ty = ty_app ts (List.map ty_var ts.ts_args) in
List.fold_left (check_constr ts ty) (syms,news) cl
List.fold_left (check_constr ts ty pjs) (syms,news) cl
in
let (syms,news) = List.fold_left check_decl (Sid.empty,Sid.empty) tdl in
mk_decl (Dtype tdl) syms news
......@@ -658,6 +688,7 @@ exception NonExhaustiveCase of pattern list * term
let rec check_matchT kn () t = match t.t_node with
| Tcase (t1,bl) ->
let bl = List.map (fun b -> let p,t = t_open_branch b in [p],t) bl in
let find_constructors kn ts = List.map fst (find_constructors kn ts) in
ignore (try Pattern.CompileTerm.compile (find_constructors kn) [t1] bl
with Pattern.NonExhaustive p -> raise (NonExhaustiveCase (p,t)));
t_fold (check_matchT kn) () t
......@@ -679,7 +710,7 @@ let rec check_foundness kn d =
we can build a value of this type *)
let tss = Sts.add ts tss in
List.exists (check_constr tss tvs) cl
and check_constr tss tvs ls =
and check_constr tss tvs (ls,_) =
(* we can construct a value iff every
argument is of an inhabited type *)
List.for_all (check_type tss tvs) ls.ls_args
......@@ -718,7 +749,7 @@ let rec ts_extract_pos kn sts ts =
if pos then get_ty acc else ty_freevars acc in
List.fold_left2 get stv (ts_extract_pos kn sts ts) tl
in
let get_cs acc ls = List.fold_left get_ty acc ls.ls_args in
let get_cs acc (ls,_) = List.fold_left get_ty acc ls.ls_args in
let negs = List.fold_left get_cs Stv.empty csl in
List.map (fun v -> not (Stv.mem v negs)) ts.ts_args
......@@ -726,7 +757,7 @@ let check_positivity kn d = match d.d_node with
| Dtype tdl ->
let add s (ts,_) = Sts.add ts s in
let tss = List.fold_left add Sts.empty tdl in
let check_constr tys cs =
let check_constr tys (cs,_) =
let rec check_ty ty = match ty.ty_node with
| Tyvar _ -> ()
| Tyapp (ts,tl) ->
......@@ -753,3 +784,44 @@ let known_add_decl kn d =
check_match kn d;
kn
(** Records *)
exception EmptyRecord
let parse_record kn fll =
let fs = match fll with
| [] -> raise EmptyRecord
| (fs,_)::_ -> fs in
let ts = match fs.ls_args with
| [{ ty_node = Tyapp (ts,_) }] -> ts
| _ -> raise (BadRecordField fs) in
let cs, pjl = match find_constructors kn ts with
| [cs,pjl] -> cs, List.map (exn_option (BadRecordField fs)) pjl
| _ -> raise (BadRecordField fs) in
let pjs = List.fold_left (fun s pj -> Sls.add pj s) Sls.empty pjl in
let flm = List.fold_left (fun m (pj,v) ->
if not (Sls.mem pj pjs) then raise (BadRecordField pj) else
Mls.add_new (DuplicateRecordField pj) pj v m) Mls.empty fll in
cs,pjl,flm
let make_record kn fll ty =
let cs,pjl,flm = parse_record kn fll in
let get_arg pj = Mls.find_exn (RecordFieldMissing pj) pj flm in
fs_app cs (List.map get_arg pjl) ty
let make_record_update kn t fll ty =
let cs,pjl,flm = parse_record kn fll in
let get_arg pj = match Mls.find_opt pj flm with
| Some v -> v
| None -> t_app_infer pj [t] in
fs_app cs (List.map get_arg pjl) ty
let make_record_pattern kn fll ty =
let cs,pjl,flm = parse_record kn fll in
let s = ty_match Mtv.empty (of_option cs.ls_value) ty in
let get_arg pj = match Mls.find_opt pj flm with
| Some v -> v
| None -> pat_wild (ty_inst s (of_option pj.ls_value))
in
pat_app cs (List.map get_arg pjl) ty
......@@ -27,9 +27,12 @@ open Term
(** {2 Type declaration} *)
type constructor = lsymbol * lsymbol option list
(** constructor symbol with the list of projections *)
type ty_defn =
| Tabstract
| Talgebraic of lsymbol list
| Talgebraic of constructor list
type ty_decl = tysymbol * ty_defn
......@@ -135,6 +138,11 @@ exception EmptyDecl
exception EmptyAlgDecl of tysymbol
exception EmptyIndDecl of lsymbol
exception BadConstructor of lsymbol
exception BadRecordField of lsymbol
exception RecordFieldMissing of lsymbol
exception DuplicateRecordField of lsymbol
(** {2 Utilities} *)
val decl_map : (term -> term) -> decl -> decl
......@@ -168,9 +176,29 @@ exception NonExhaustiveCase of pattern list * term
exception NonFoundedTypeDecl of tysymbol
val find_type_definition : known_map -> tysymbol -> ty_defn
val find_constructors : known_map -> tysymbol -> lsymbol list
val find_constructors : known_map -> tysymbol -> constructor list
val find_inductive_cases : known_map -> lsymbol -> (prsymbol * term) list
val find_logic_definition : known_map -> lsymbol -> ls_defn option
val find_prop : known_map -> prsymbol -> term
val find_prop_decl : known_map -> prsymbol -> prop_kind * term
(** Records *)
exception EmptyRecord
val parse_record :
known_map -> (lsymbol * 'a) list -> lsymbol * lsymbol list * 'a Mls.t
(** [parse_record kn field_list] takes a list of record field assignments,
checks it for well-formedness and returns the corresponding constructor,
the full list of projection symbols, and the map from projection symbols
to assigned values. *)
val make_record :
known_map -> (lsymbol * term) list -> ty -> term
val make_record_update :
known_map -> term -> (lsymbol * term) list -> ty -> term
val make_record_pattern :
known_map -> (lsymbol * pattern) list -> ty -> pattern
......@@ -296,13 +296,16 @@ let print_tv_arg fmt tv = fprintf fmt "@ %a" print_tv tv
let print_ty_arg fmt ty = fprintf fmt "@ %a" (print_ty_node true) ty
let print_vs_arg fmt vs = fprintf fmt "@ (%a)" print_vsty vs
let print_constr ty fmt cs =
let ty_val = of_option cs.ls_value in
let m = ty_match Mtv.empty ty_val ty in
let tl = List.map (ty_inst m) cs.ls_args in
let print_constr fmt (cs,pjl) =
let add_pj pj ty pjl = (pj,ty)::pjl in
let print_pj fmt (pj,ty) = match pj with
| Some ls -> fprintf fmt "@ (%a:@,%a)" print_ls ls print_ty ty
| None -> print_ty_arg fmt ty
in
fprintf fmt "@[<hov 4>| %a%a%a@]" print_cs cs
print_ident_labels cs.ls_name
(print_list nothing print_ty_arg) tl
(print_list nothing print_pj)
(List.fold_right2 add_pj pjl cs.ls_args [])
let print_type_decl fst fmt (ts,def) = match def with
| Tabstract -> begin match ts.ts_def with
......@@ -318,12 +321,11 @@ let print_type_decl fst fmt (ts,def) = match def with
(print_list nothing print_tv_arg) ts.ts_args print_ty ty
end
| Talgebraic csl ->
let ty = ty_app ts (List.map ty_var ts.ts_args) in
fprintf fmt "@[<hov 2>%s %a%a%a =@\n@[<hov>%a@]@]"
(if fst then "type" else "with") print_ts ts
print_ident_labels ts.ts_name
(print_list nothing print_tv_arg) ts.ts_args
(print_list newline (print_constr ty)) csl
(print_list newline print_constr) csl
let print_type_decl first fmt d =
print_type_decl first fmt d; forget_tvs ()
......@@ -534,6 +536,14 @@ let () = Exn_printer.register
| Pattern.NonExhaustive pl ->
fprintf fmt "Non-exhaustive pattern list:@\n@[<hov 2>%a@]"
(print_list newline print_pat) pl
| Decl.BadConstructor ls ->
fprintf fmt "Bad constructor symbol: %a" print_ls ls
| Decl.BadRecordField ls ->
fprintf fmt "Not a record field: %a" print_ls ls
| Decl.RecordFieldMissing ls ->
fprintf fmt "Record field missing: %a" print_ls ls
| Decl.DuplicateRecordField ls ->
fprintf fmt "Duplicate record field: %a" print_ls ls
| Decl.IllegalTypeAlias ts ->
fprintf fmt
"Type symbol %a is a type alias and cannot be declared as algebraic"
......
......@@ -352,7 +352,12 @@ let add_symbol add id v uc =
| _ -> assert false
let add_type uc (ts,def) =
let add_constr uc fs = add_symbol add_ls fs.ls_name fs uc in
let add_proj uc = function
| Some pj -> add_symbol add_ls pj.ls_name pj uc
| None -> uc in
let add_constr uc (fs,pl) =
let uc = add_symbol add_ls fs.ls_name fs uc in
List.fold_left add_proj uc pl in
let uc = add_symbol add_ts ts.ts_name ts uc in
match def with
| Tabstract -> uc
......@@ -513,11 +518,14 @@ let cl_init th inst =
(* clone declarations *)
let cl_type cl inst tdl =
let add_constr ls =
let add_ls ls =
if Mls.mem ls inst.inst_ls
then raise (CannotInstantiate ls.ls_name)
else cl_find_ls cl ls
in
let add_constr (ls,pl) =
add_ls ls, List.map (option_map add_ls) pl
in
let add_type (ts,td) acc =
if Mts.mem ts inst.inst_ts then
if ts.ts_def = None && td = Tabstract then acc
......@@ -749,7 +757,7 @@ let create_theory ?(path=[]) n =
let bool_theory =
let uc = empty_theory (id_fresh "Bool") [] in
let uc = add_ty_decl uc [ts_bool, Talgebraic [fs_true; fs_false]] in
let uc = add_ty_decl uc [ts_bool, Talgebraic [fs_true,[]; fs_false,[]]] in
close_theory uc
let highord_theory =
......@@ -761,8 +769,10 @@ let highord_theory =
close_theory uc
let tuple_theory = Util.memo_int 17 (fun n ->
let ts = ts_tuple n and fs = fs_tuple n in
let pl = List.map (fun _ -> None) ts.ts_args in
let uc = empty_theory (id_fresh ("Tuple" ^ string_of_int n)) [] in
let uc = add_ty_decl uc [ts_tuple n, Talgebraic [fs_tuple n]] in
let uc = add_ty_decl uc [ts, Talgebraic [fs,pl]] in
close_theory uc)
let tuple_theory_name s =
......
......@@ -31,17 +31,14 @@ open Denv
(** errors *)
exception DuplicateVar of string
exception DuplicateTypeVar of string
exception TypeArity of qualid * int * int
exception Clash of string
exception PredicateExpected
exception TermExpected
exception FSymExpected of lsymbol
exception PSymExpected of lsymbol
exception BadNumberOfArguments of Ident.ident * int * int
exception ClashTheory of string
exception UnboundTheory of qualid
exception CyclicTypeDef
exception UnboundTypeVar of string
exception UnboundType of string list
exception UnboundSymbol of string list
......@@ -56,12 +53,9 @@ let rec print_qualid fmt = function
let () = Exn_printer.register (fun fmt e -> match e with
| DuplicateTypeVar s ->
fprintf fmt "duplicate type parameter %s" s
| TypeArity (id, a, n) ->
fprintf fmt "@[The type %a expects %d argument(s),@ " print_qualid id a;
fprintf fmt "but is applied to %d argument(s)@]" n
| Clash id ->
fprintf fmt "Clash with previous symbol %s" id
fprintf fmt "Duplicate type parameter %s" s
| DuplicateVar s ->
fprintf fmt "Duplicate variable %s" s
| PredicateExpected ->
fprintf fmt "syntax error: predicate expected"
| TermExpected ->
......@@ -70,15 +64,10 @@ let () = Exn_printer.register (fun fmt e -> match e with
fprintf fmt "%a is not a function symbol" Pretty.print_ls ls
| PSymExpected ls ->
fprintf fmt "%a is not a predicate symbol" Pretty.print_ls ls
| BadNumberOfArguments (s, n, m) ->
fprintf fmt "@[Symbol `%s' is applied to %d terms,@ " s.id_string n;
fprintf fmt "but is expecting %d arguments@]" m
| ClashTheory s ->
fprintf fmt "clash with previous theory %s" s
fprintf fmt "Clash with previous theory %s" s
| UnboundTheory q ->
fprintf fmt "unbound theory %a" print_qualid q
| CyclicTypeDef ->
fprintf fmt "cyclic type definition"
| UnboundTypeVar s ->
fprintf fmt "unbound type variable '%s" s
| UnboundType sl ->
......@@ -105,7 +94,7 @@ let debug_type_only = Debug.register_stop_flag "type_only"
let term_expected_type ~loc ty1 ty2 =
errorm ~loc
"@[This term has type %a@ but is expected to have type@ %a@]"
"This term has type %a@ but is expected to have type@ %a"
print_dty ty1 print_dty ty2
let unify_raise ~loc ty1 ty2 =
......@@ -157,11 +146,8 @@ let rec string_list_of_qualid acc = function
let specialize_tysymbol loc p uc =
let sl = string_list_of_qualid [] p in
let ts =
try ns_find_ts (get_namespace uc) sl
with Not_found -> error ~loc (UnboundType sl)
in
ts, List.length ts.ts_args
try ns_find_ts (get_namespace uc) sl
with Not_found -> error ~loc (UnboundType sl)
(* lazy declaration of tuples *)
......@@ -175,11 +161,9 @@ let rec dty uc env = function
tyvar (find_user_type_var x env)
| PPTtyapp (p, x) ->
let loc = qloc x in
let ts, a = specialize_tysymbol loc x uc in
let np = List.length p in
if np <> a then error ~loc (TypeArity (x, a, np));
let ts = specialize_tysymbol loc x uc in
let tyl = List.map (dty uc env) p in
tyapp ts tyl
Loc.try2 loc tyapp ts tyl
| PPTtuple tyl ->
let ts = ts_tuple (List.length tyl) in
tyapp ts (List.map (dty uc env) tyl)
......@@ -234,6 +218,7 @@ let is_psymbol p uc =
let s = find_lsymbol p uc in
s.ls_value = None
(*
(* [is_projection uc ls] returns
- [Some (ts, lsc, i)] if [ls] is the i-th projection of an
algebraic datatype [ts] with only one constructor [lcs]
......@@ -307,6 +292,7 @@ let list_fields uc fl =
in
List.iter check_field fl;
ts,cs,Array.to_list args
*)
(** Typing types *)
......@@ -326,9 +312,7 @@ let binop = function
let check_pat_linearity p =
let s = ref Sstr.empty in
let add id =
if Sstr.mem id.id !s then
errorm ~loc:id.id_loc "duplicate variable %s" id.id;
s := Sstr.add id.id !s
s := Loc.try3 id.id_loc Sstr.add_new (DuplicateVar id.id) id.id !s
in
let rec check p = match p.pat_desc with
| PPpwild -> ()
......@@ -358,27 +342,30 @@ and dpat_node loc uc env = function
env, Pvar x, ty
| PPpapp (x, pl) ->
let s, tyl, ty = specialize_fsymbol x uc in
let env, pl = dpat_args s.ls_name loc uc env tyl pl in
let env, pl = dpat_args s loc uc env tyl pl in
env, Papp (s, pl), ty
| PPprec fl ->
let renv = ref env in
let _,cs,fl = list_fields uc fl in
let fl = List.map (fun (q,e) -> find_lsymbol q uc,e) fl in
let cs,pjl,flm = Loc.try2 loc parse_record (get_known uc) fl in
let tyl,ty = Denv.specialize_lsymbol ~loc cs in
let al = List.map2 (fun f ty -> match f with
| Some (_,e) ->
let get_val pj ty = match Mls.find_opt pj flm with
| Some e ->
let loc = e.pat_loc in
let env,e = dpat uc !renv e in
unify_raise ~loc e.dp_ty ty;
renv := env;
e
| None -> { dp_node = Pwild; dp_ty = ty }) fl tyl
| None ->
{ dp_node = Pwild; dp_ty = ty }
in
!renv, Papp (cs,al), Util.of_option ty
let al = List.map2 get_val pjl tyl in
!renv, Papp (cs, al), Util.of_option ty
| PPptuple pl ->
let n = List.length pl in
let s = fs_tuple n in
let tyl = List.map (fun _ -> fresh_type_var loc) pl in
let env, pl = dpat_args s.ls_name loc uc env tyl pl in
let env, pl = dpat_args s loc uc env tyl pl in
let ty = tyapp (ts_tuple n) tyl in
env, Papp (s, pl), ty
| PPpas (p, x) ->
......@@ -391,9 +378,9 @@ and dpat_node loc uc env = function
unify_raise ~loc p.dp_ty q.dp_ty;
env, Por (p,q), p.dp_ty
and dpat_args s loc uc env el pl =
and dpat_args ls loc uc env el pl =
let n = List.length el and m = List.length pl in
if n <> m then error ~loc (BadNumberOfArguments (s, m, n));
if n <> m then error ~loc (BadArity (ls,m,n));
let rec check_arg env = function
| [], [] ->
env, []
......@@ -416,8 +403,7 @@ let rec trigger_not_a_term_exn = function
let check_quant_linearity uqu =
let s = ref Sstr.empty in
let check id =
if Sstr.mem id.id !s then errorm ~loc:id.id_loc "duplicate variable %s" id.id;
s := Sstr.add id.id !s
s := Loc.try3 id.id_loc Sstr.add_new (DuplicateVar id.id) id.id !s
in
List.iter (fun (idl, _) -> Util.option_iter check idl) uqu
......@@ -452,27 +438,27 @@ and dterm_node ~localize loc uc env = function
(* 0-arity symbol (constant) *)
let s, tyl, ty = specialize_fsymbol x uc in
let n = List.length tyl in
if n > 0 then error ~loc (BadNumberOfArguments (s.ls_name, 0, n));
if n > 0 then error ~loc (BadArity (s, 0, n));
Tapp (s, []), ty
| PPapp (x, tl) when check_highord uc env x tl ->
let tl = apply_highord loc x tl in
let atyl, aty = Denv.specialize_lsymbol ~loc fs_func_app in
let tl = dtype_args ~localize fs_func_app.ls_name loc uc env atyl tl in
let tl = dtype_args ~localize fs_func_app loc uc env atyl tl in
Tapp (fs_func_app, tl), Util.of_option aty
| PPapp (x, tl) ->
let s, tyl, ty = specialize_fsymbol x uc in
let tl = dtype_args ~localize s.ls_name loc uc env tyl tl in
let tl = dtype_args ~localize s loc uc env tyl tl in
Tapp (s, tl), ty
| PPtuple tl ->
let n = List.length tl in
let s = fs_tuple n in
let tyl = List.map (fun _ -> fresh_type_var loc) tl in
let tl = dtype_args ~localize s.ls_name loc uc env tyl tl in
let tl = dtype_args ~localize s loc uc env tyl tl in
let ty = tyapp (ts_tuple n) tyl in
Tapp (s, tl), ty
| PPinfix (e1, x, e2) ->
let s, tyl, ty = specialize_fsymbol (Qident x) uc in
let tl = dtype_args ~localize s.ls_name loc uc env tyl [e1; e2] in
let tl = dtype_args ~localize s loc uc env tyl [e1; e2] in
Tapp (s, tl), ty
| PPconst (ConstInt _ as c) ->
Tconst c, tyapp Ty.ts_int []
......@@ -580,58 +566,39 @@ and dterm_node ~localize loc uc env = function
in
Teps (id, ty, Fquant (Tforall, uqu, trl, f)), ty
| PPrecord fl ->
let _,cs,fl = list_fields uc fl in
let fl = List.map (fun (q,e) -> find_lsymbol q uc,e) fl in
let cs,pjl,flm = Loc.try2 loc parse_record (get_known uc) fl in
let tyl,ty = Denv.specialize_lsymbol ~loc cs in
let al = List.map2 (fun f ty -> match f with
| Some (_,e) ->
let get_val pj ty = match Mls.find_opt pj flm with
| Some e ->
let loc = e.pp_loc in
let e = dterm ~localize uc env e in
unify_raise ~loc e.dt_ty ty;
e
| None -> errorm ~loc "some record fields are missing") fl tyl
| None -> error ~loc (RecordFieldMissing pj)
in
let al = List.map2 get_val pjl tyl in
Tapp (cs,al), Util.of_option ty
| PPupdate (e,fl) ->
let n = ref (-1) in
let q = Queue.create () in
let e = dterm ~localize uc env e in
let _,cs,fl = list_fields uc fl in
(* prepare the pattern *)
let tyl,ty = Denv.specialize_lsymbol ~loc cs in
unify_raise ~loc e.dt_ty (Util.of_option ty);
let pl = List.map2 (fun f ty -> match f with
| Some _ ->
{ dp_node = Pwild ; dp_ty = ty }
| None ->
let x = (incr n; "x:" ^ string_of_int !n) in
let i = { id = x ; id_lab = []; id_loc = loc } in
Queue.add (x,ty) q;
{ dp_node = Pvar i ; dp_ty = ty }) fl tyl
in
let p = { dp_node = Papp (cs,pl) ; dp_ty = e.dt_ty } in
(* prepare the result *)
let fl = List.map (fun (q,e) -> find_lsymbol q uc,e) fl in
let cs,pjl,flm = Loc.try2 loc parse_record (get_known uc) fl in
let tyl,ty = Denv.specialize_lsymbol ~loc cs in
let set_pat_var_ty f tyf = match f with
| Some _ ->
()