Commit 983a6d61 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

drop a redundant argument from "bad arity" exceptions

parent 10568fd0
...@@ -500,20 +500,20 @@ let () = Exn_printer.register ...@@ -500,20 +500,20 @@ let () = Exn_printer.register
| Ty.TypeMismatch (t1,t2) -> | Ty.TypeMismatch (t1,t2) ->
fprintf fmt "Type mismatch between %a and %a" fprintf fmt "Type mismatch between %a and %a"
print_ty t1 print_ty t2 print_ty t1 print_ty t2
| Ty.BadTypeArity (ts, ts_arg, app_arg) -> | Ty.BadTypeArity (ts, app_arg) ->
fprintf fmt "Bad type arity: type symbol %a must be applied \ fprintf fmt "Bad type arity: type symbol %a must be applied \
to %i arguments, but is applied to %i" to %i arguments, but is applied to %i"
print_ts ts ts_arg app_arg print_ts ts (List.length ts.ts_args) app_arg
| Ty.DuplicateTypeVar tv -> | Ty.DuplicateTypeVar tv ->
fprintf fmt "Type variable %a is used twice" print_tv tv fprintf fmt "Type variable %a is used twice" print_tv tv
| Ty.UnboundTypeVar tv -> | Ty.UnboundTypeVar tv ->
fprintf fmt "Unbound type variable: %a" print_tv tv fprintf fmt "Unbound type variable: %a" print_tv tv
| Ty.UnexpectedProp -> | Ty.UnexpectedProp ->
fprintf fmt "Unexpected propositional type" fprintf fmt "Unexpected propositional type"
| Term.BadArity (ls, ls_arg, app_arg) -> | Term.BadArity (ls, app_arg) ->
fprintf fmt "Bad arity: symbol %a must be applied \ fprintf fmt "Bad arity: symbol %a must be applied \
to %i arguments, but is applied to %i" to %i arguments, but is applied to %i"
print_ls ls ls_arg app_arg print_ls ls (List.length ls.ls_args) app_arg
| Term.EmptyCase -> | Term.EmptyCase ->
fprintf fmt "Empty match expression" fprintf fmt "Empty match expression"
| Term.DuplicateVar vs -> | Term.DuplicateVar vs ->
......
...@@ -202,7 +202,7 @@ let pat_any pr pat = ...@@ -202,7 +202,7 @@ let pat_any pr pat =
(* smart constructors for patterns *) (* smart constructors for patterns *)
exception BadArity of lsymbol * int * int exception BadArity of lsymbol * int
exception FunctionSymbolExpected of lsymbol exception FunctionSymbolExpected of lsymbol
exception PredicateSymbolExpected of lsymbol exception PredicateSymbolExpected of lsymbol
exception ConstructorExpected of lsymbol exception ConstructorExpected of lsymbol
...@@ -213,9 +213,8 @@ let pat_app fs pl ty = ...@@ -213,9 +213,8 @@ let pat_app fs pl ty =
| None -> raise (FunctionSymbolExpected fs) | None -> raise (FunctionSymbolExpected fs)
in in
let mtch s ty p = ty_match s ty p.pat_ty in let mtch s ty p = ty_match s ty p.pat_ty in
ignore (try List.fold_left2 mtch s fs.ls_args pl ignore (try List.fold_left2 mtch s fs.ls_args pl with
with Invalid_argument _ -> raise (BadArity | Invalid_argument _ -> raise (BadArity (fs, List.length pl)));
(fs, List.length fs.ls_args, List.length pl)));
if fs.ls_constr = 0 then raise (ConstructorExpected fs); if fs.ls_constr = 0 then raise (ConstructorExpected fs);
pat_app fs pl ty pat_app fs pl ty
...@@ -707,9 +706,8 @@ let t_open_quant_cb fq = ...@@ -707,9 +706,8 @@ let t_open_quant_cb fq =
let ls_arg_inst ls tl = let ls_arg_inst ls tl =
let mtch s ty t = ty_match s ty (t_type t) in let mtch s ty t = ty_match s ty (t_type t) in
try List.fold_left2 mtch Mtv.empty ls.ls_args tl try List.fold_left2 mtch Mtv.empty ls.ls_args tl with
with Invalid_argument _ -> raise (BadArity | Invalid_argument _ -> raise (BadArity (ls, List.length tl))
(ls, List.length ls.ls_args, List.length tl))
let ls_app_inst ls tl ty = let ls_app_inst ls tl ty =
let s = ls_arg_inst ls tl in let s = ls_arg_inst ls tl in
......
...@@ -66,7 +66,7 @@ val ls_ty_freevars : lsymbol -> Stv.t ...@@ -66,7 +66,7 @@ val ls_ty_freevars : lsymbol -> Stv.t
exception EmptyCase exception EmptyCase
exception DuplicateVar of vsymbol exception DuplicateVar of vsymbol
exception UncoveredVar of vsymbol exception UncoveredVar of vsymbol
exception BadArity of lsymbol * int * int exception BadArity of lsymbol * int
exception FunctionSymbolExpected of lsymbol exception FunctionSymbolExpected of lsymbol
exception PredicateSymbolExpected of lsymbol exception PredicateSymbolExpected of lsymbol
exception ConstructorExpected of lsymbol exception ConstructorExpected of lsymbol
......
...@@ -115,7 +115,7 @@ let meta_hash m = m.meta_tag ...@@ -115,7 +115,7 @@ let meta_hash m = m.meta_tag
exception KnownMeta of meta exception KnownMeta of meta
exception UnknownMeta of string exception UnknownMeta of string
exception BadMetaArity of meta * int * int exception BadMetaArity of meta * int
exception MetaTypeMismatch of meta * meta_arg_type * meta_arg_type exception MetaTypeMismatch of meta * meta_arg_type * meta_arg_type
let meta_table = Hstr.create 17 let meta_table = Hstr.create 17
...@@ -767,9 +767,8 @@ let create_meta m al = ...@@ -767,9 +767,8 @@ let create_meta m al =
let mt = get_meta_arg_type a in let mt = get_meta_arg_type a in
if at = mt then a else raise (MetaTypeMismatch (m,at,mt)) if at = mt then a else raise (MetaTypeMismatch (m,at,mt))
in in
let al = try List.map2 get_meta_arg m.meta_type al let al = try List.map2 get_meta_arg m.meta_type al with
with Invalid_argument _ -> | Invalid_argument _ -> raise (BadMetaArity (m, List.length al))
raise (BadMetaArity (m, List.length m.meta_type, List.length al))
in in
mk_tdecl (Meta (m,al)) mk_tdecl (Meta (m,al))
...@@ -907,9 +906,9 @@ let () = Exn_printer.register ...@@ -907,9 +906,9 @@ let () = Exn_printer.register
| KnownMeta m -> | KnownMeta m ->
Format.fprintf fmt "Metaproperty %s is already registered with \ Format.fprintf fmt "Metaproperty %s is already registered with \
a conflicting signature" m.meta_name a conflicting signature" m.meta_name
| BadMetaArity (m,i1,i2) -> | BadMetaArity (m,n) ->
Format.fprintf fmt "Metaproperty %s requires %d arguments but \ Format.fprintf fmt "Metaproperty %s requires %d arguments but \
is applied to %d" m.meta_name i1 i2 is applied to %d" m.meta_name (List.length m.meta_type) n
| MetaTypeMismatch (m,t1,t2) -> | MetaTypeMismatch (m,t1,t2) ->
Format.fprintf fmt "Metaproperty %s expects %a argument but \ Format.fprintf fmt "Metaproperty %s expects %a argument but \
is applied to %a" is applied to %a"
......
...@@ -220,6 +220,6 @@ exception ClashSymbol of string ...@@ -220,6 +220,6 @@ exception ClashSymbol of string
exception KnownMeta of meta exception KnownMeta of meta
exception UnknownMeta of string exception UnknownMeta of string
exception BadMetaArity of meta * int * int exception BadMetaArity of meta * int
exception MetaTypeMismatch of meta * meta_arg_type * meta_arg_type exception MetaTypeMismatch of meta * meta_arg_type * meta_arg_type
...@@ -144,7 +144,7 @@ let ty_closed ty = ty_v_all Util.ffalse ty ...@@ -144,7 +144,7 @@ let ty_closed ty = ty_v_all Util.ffalse ty
(* smart constructors *) (* smart constructors *)
exception BadTypeArity of tysymbol * int * int exception BadTypeArity of tysymbol * int
exception DuplicateTypeVar of tvsymbol exception DuplicateTypeVar of tvsymbol
exception UnboundTypeVar of tvsymbol exception UnboundTypeVar of tvsymbol
...@@ -155,17 +155,15 @@ let create_tysymbol name args def = ...@@ -155,17 +155,15 @@ let create_tysymbol name args def =
ignore (Opt.map (ty_v_all check) def); ignore (Opt.map (ty_v_all check) def);
mk_ts name args def mk_ts name args def
let ty_app s tl = let ty_app s tl = match s.ts_def with
let tll = List.length tl in | Some ty ->
let stl = List.length s.ts_args in let mv = try List.fold_right2 Mtv.add s.ts_args tl Mtv.empty with
if tll <> stl then raise (BadTypeArity (s,stl,tll)); | Invalid_argument _ -> raise (BadTypeArity (s, List.length tl)) in
match s.ts_def with ty_full_inst mv ty
| Some ty -> | None ->
let add m v t = Mtv.add v t m in if List.length s.ts_args <> List.length tl then
let m = List.fold_left2 add Mtv.empty s.ts_args tl in raise (BadTypeArity (s, List.length tl));
ty_full_inst m ty ty_app s tl
| _ ->
ty_app s tl
(* symbol-wise map/fold *) (* symbol-wise map/fold *)
......
...@@ -61,7 +61,7 @@ val ty_equal : ty -> ty -> bool ...@@ -61,7 +61,7 @@ val ty_equal : ty -> ty -> bool
val ts_hash : tysymbol -> int val ts_hash : tysymbol -> int
val ty_hash : ty -> int val ty_hash : ty -> int
exception BadTypeArity of tysymbol * int * int exception BadTypeArity of tysymbol * int
exception DuplicateTypeVar of tvsymbol exception DuplicateTypeVar of tvsymbol
exception UnboundTypeVar of tvsymbol exception UnboundTypeVar of tvsymbol
......
...@@ -326,7 +326,7 @@ and dpat_node loc uc env = function ...@@ -326,7 +326,7 @@ and dpat_node loc uc env = function
and dpat_args ls 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 let n = List.length el and m = List.length pl in
if n <> m then error ~loc (BadArity (ls,n,m)); if n <> m then error ~loc (BadArity (ls,m));
let rec check_arg env = function let rec check_arg env = function
| [], [] -> | [], [] ->
env, [] env, []
...@@ -402,8 +402,7 @@ and dterm_node ~localize loc uc env = function ...@@ -402,8 +402,7 @@ and dterm_node ~localize loc uc env = function
| PPvar x -> | PPvar x ->
(* 0-arity symbol (constant) *) (* 0-arity symbol (constant) *)
let s, tyl, ty = specialize_fsymbol x uc in let s, tyl, ty = specialize_fsymbol x uc in
let n = List.length tyl in if tyl <> [] then error ~loc (BadArity (s,0));
if n > 0 then error ~loc (BadArity (s,n,0));
Tapp (s, []), ty Tapp (s, []), ty
| PPapp (x, tl) when check_highord uc env x tl -> | PPapp (x, tl) when check_highord uc env x tl ->
let tl = apply_highord loc x tl in let tl = apply_highord loc x tl in
...@@ -666,7 +665,7 @@ and dpat_list uc env ty p = ...@@ -666,7 +665,7 @@ and dpat_list uc env ty p =
and dtype_args ~localize ls loc uc env el tl = and dtype_args ~localize ls loc uc env el tl =
let n = List.length el and m = List.length tl in let n = List.length el and m = List.length tl in
if n <> m then error ~loc (BadArity (ls,n,m)); if n <> m then error ~loc (BadArity (ls,m));
let rec check_arg = function let rec check_arg = function
| [], [] -> | [], [] ->
[] []
......
...@@ -69,28 +69,24 @@ and reg_refresh mv mr r = match Mreg.find_opt r mr with ...@@ -69,28 +69,24 @@ and reg_refresh mv mr r = match Mreg.find_opt r mr with
let reg = create_dreg ity in let reg = create_dreg ity in
Mreg.add r reg mr, reg Mreg.add r reg mr, reg
let its_app s tl = let its_app s dl =
let add m v t = Mtv.add v t m in let mv = try List.fold_right2 Mtv.add s.its_ts.ts_args dl Mtv.empty with
let mv = try List.fold_left2 add Mtv.empty s.its_ts.ts_args tl | Invalid_argument _ -> raise (BadItyArity (s, List.length dl)) in
with Invalid_argument _ ->
raise (BadItyArity (s, List.length s.its_ts.ts_args, List.length tl)) in
match s.its_def with match s.its_def with
| Some ity -> | Some ity ->
snd (ity_inst_fresh mv Mreg.empty ity) snd (ity_inst_fresh mv Mreg.empty ity)
| None -> | None ->
let _,rl = Lists.map_fold_left (reg_refresh mv) Mreg.empty s.its_regs in let _,rl = Lists.map_fold_left (reg_refresh mv) Mreg.empty s.its_regs in
its_app_real s tl rl its_app_real s dl rl
let ts_app ts dl = let ts_app s dl =
let add m v t = Mtv.add v t m in let mv = try List.fold_right2 Mtv.add s.ts_args dl Mtv.empty with
let mv = try List.fold_left2 add Mtv.empty ts.ts_args dl | Invalid_argument _ -> raise (BadTypeArity (s, List.length dl)) in
with Invalid_argument _ -> match s.ts_def with
raise (BadTypeArity (ts, List.length ts.ts_args, List.length dl)) in
match ts.ts_def with
| Some ty -> | Some ty ->
snd (ity_inst_fresh mv Mreg.empty (ity_of_ty ty)) snd (ity_inst_fresh mv Mreg.empty (ity_of_ty ty))
| None -> | None ->
ts_app_real ts dl ts_app_real s dl
let rec dity_refresh = function let rec dity_refresh = function
| Dvar { contents = Dtvs _ } as dity -> dity | Dvar { contents = Dtvs _ } as dity -> dity
......
...@@ -177,7 +177,7 @@ let make_ppattern pp ?(ghost=false) ity = ...@@ -177,7 +177,7 @@ let make_ppattern pp ?(ghost=false) ity =
let ppl = try List.map2 mtch pls.pl_args ppl with let ppl = try List.map2 mtch pls.pl_args ppl with
| Not_found -> raise (Term.ConstructorExpected pls.pl_ls) | Not_found -> raise (Term.ConstructorExpected pls.pl_ls)
| Invalid_argument _ -> raise (Term.BadArity | Invalid_argument _ -> raise (Term.BadArity
(pls.pl_ls, List.length pls.pl_args, List.length ppl)) in (pls.pl_ls, List.length ppl)) in
make_app pls.pl_ls ppl ghost ity make_app pls.pl_ls ppl ghost ity
| PPlapp (ls,ppl) -> | PPlapp (ls,ppl) ->
if ls.ls_constr = 0 then if ls.ls_constr = 0 then
...@@ -190,7 +190,7 @@ let make_ppattern pp ?(ghost=false) ity = ...@@ -190,7 +190,7 @@ let make_ppattern pp ?(ghost=false) ity =
let ppl = try List.map2 mtch ls.ls_args ppl with let ppl = try List.map2 mtch ls.ls_args ppl with
| Not_found -> raise (Term.ConstructorExpected ls) | Not_found -> raise (Term.ConstructorExpected ls)
| Invalid_argument _ -> raise (Term.BadArity | Invalid_argument _ -> raise (Term.BadArity
(ls,List.length ls.ls_args,List.length ppl)) in (ls, List.length ppl)) in
make_app ls ppl ghost ity make_app ls ppl ghost ity
| PPor (pp1,pp2) -> | PPor (pp1,pp2) ->
let pp1 = make ghost ity pp1 in let pp1 = make ghost ity pp1 in
...@@ -603,8 +603,7 @@ let e_plapp pls el ity = ...@@ -603,8 +603,7 @@ let e_plapp pls el ity =
| None -> ps_app pls.pl_ls tl in | None -> ps_app pls.pl_ls tl in
mk_expr (Elogic t) (VTvalue ity) ghost eff syms mk_expr (Elogic t) (VTvalue ity) ghost eff syms
| [],_ | _,[] -> | [],_ | _,[] ->
raise (Term.BadArity raise (Term.BadArity (pls.pl_ls, List.length el))
(pls.pl_ls, List.length pls.pl_args, List.length el))
| fd::fdl, ({ e_node = Elogic t } as e)::argl -> | fd::fdl, ({ e_node = Elogic t } as e)::argl ->
let t = match t.t_ty with let t = match t.t_ty with
| Some _ -> t | Some _ -> t
......
...@@ -426,14 +426,14 @@ let print_pdecl fmt d = match d.pd_node with ...@@ -426,14 +426,14 @@ let print_pdecl fmt d = match d.pd_node with
let () = Exn_printer.register let () = Exn_printer.register
begin fun fmt exn -> match exn with begin fun fmt exn -> match exn with
| Mlw_ty.BadItyArity (ts, ts_arg, app_arg) -> | Mlw_ty.BadItyArity (ts, app_arg) ->
fprintf fmt "Bad type arity: type symbol %a must be applied \ fprintf fmt "Bad type arity: type symbol %a must be applied \
to %i arguments, but is applied to %i" to %i arguments, but is applied to %i"
print_its ts ts_arg app_arg print_its ts (List.length ts.its_ts.ts_args) app_arg
| Mlw_ty.BadRegArity (ts, ts_arg, app_arg) -> | Mlw_ty.BadRegArity (ts, app_arg) ->
fprintf fmt "Bad region arity: type symbol %a must be applied \ fprintf fmt "Bad region arity: type symbol %a must be applied \
to %i regions, but is applied to %i" to %i regions, but is applied to %i"
print_its ts ts_arg app_arg print_its ts (List.length ts.its_regs) app_arg
| Mlw_ty.DuplicateRegion r -> | Mlw_ty.DuplicateRegion r ->
fprintf fmt "Region %a is used twice" print_reg r fprintf fmt "Region %a is used twice" print_reg r
| Mlw_ty.UnboundRegion r -> | Mlw_ty.UnboundRegion r ->
......
...@@ -291,8 +291,8 @@ let lookup_nonghost_reg regs ity = ...@@ -291,8 +291,8 @@ let lookup_nonghost_reg regs ity =
(* smart constructors *) (* smart constructors *)
exception BadItyArity of itysymbol * int * int exception BadItyArity of itysymbol * int
exception BadRegArity of itysymbol * int * int exception BadRegArity of itysymbol * int
exception DuplicateRegion of region exception DuplicateRegion of region
exception UnboundRegion of region exception UnboundRegion of region
...@@ -389,10 +389,8 @@ and reg_refresh mv mr r = match Mreg.find_opt r mr with ...@@ -389,10 +389,8 @@ and reg_refresh mv mr r = match Mreg.find_opt r mr with
let ity_app_fresh s tl = let ity_app_fresh s tl =
(* type variable map *) (* type variable map *)
let add m v t = Mtv.add v t m in let mv = try List.fold_right2 Mtv.add s.its_ts.ts_args tl Mtv.empty with
let mv = try List.fold_left2 add Mtv.empty s.its_ts.ts_args tl | Invalid_argument _ -> raise (BadItyArity (s, List.length tl)) in
with Invalid_argument _ ->
raise (BadItyArity (s, List.length s.its_ts.ts_args, List.length tl)) in
(* refresh regions *) (* refresh regions *)
let mr,rl = Lists.map_fold_left (reg_refresh mv) Mreg.empty s.its_regs in let mr,rl = Lists.map_fold_left (reg_refresh mv) Mreg.empty s.its_regs in
let sub = { ity_subst_tv = mv; ity_subst_reg = mr } in let sub = { ity_subst_tv = mv; ity_subst_reg = mr } in
...@@ -403,15 +401,12 @@ let ity_app_fresh s tl = ...@@ -403,15 +401,12 @@ let ity_app_fresh s tl =
let ity_app s tl rl = let ity_app s tl rl =
(* type variable map *) (* type variable map *)
let add m v t = Mtv.add v t m in let mv = try List.fold_right2 Mtv.add s.its_ts.ts_args tl Mtv.empty with
let mv = try List.fold_left2 add Mtv.empty s.its_ts.ts_args tl | Invalid_argument _ -> raise (BadItyArity (s, List.length tl)) in
with Invalid_argument _ ->
raise (BadItyArity (s, List.length s.its_ts.ts_args, List.length tl)) in
(* region map *) (* region map *)
let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in
let sub = try List.fold_left2 reg_match sub s.its_regs rl let sub = try List.fold_left2 reg_match sub s.its_regs rl with
with Invalid_argument _ -> | Invalid_argument _ -> raise (BadRegArity (s, List.length rl)) in
raise (BadRegArity (s, List.length s.its_regs, List.length rl)) in
(* every type var and top region in def are in its_ts.ts_args and its_regs *) (* every type var and top region in def are in its_ts.ts_args and its_regs *)
match s.its_def with match s.its_def with
| Some ity -> ity_full_inst sub ity | Some ity -> ity_full_inst sub ity
...@@ -419,10 +414,8 @@ let ity_app s tl rl = ...@@ -419,10 +414,8 @@ let ity_app s tl rl =
let ity_pur s tl = let ity_pur s tl =
(* type variable map *) (* type variable map *)
let add m v t = Mtv.add v t m in let mv = try List.fold_right2 Mtv.add s.ts_args tl Mtv.empty with
let mv = try List.fold_left2 add Mtv.empty s.ts_args tl | Invalid_argument _ -> raise (Ty.BadTypeArity (s, List.length tl)) in
with Invalid_argument _ ->
raise (Ty.BadTypeArity (s, List.length s.ts_args, List.length tl)) in
let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in
(* every top region in def is guaranteed to be in mr *) (* every top region in def is guaranteed to be in mr *)
match s.ts_def with match s.ts_def with
......
...@@ -78,8 +78,8 @@ val ity_hash : ity -> int ...@@ -78,8 +78,8 @@ val ity_hash : ity -> int
val reg_equal : region -> region -> bool val reg_equal : region -> region -> bool
val reg_hash : region -> int val reg_hash : region -> int
exception BadItyArity of itysymbol * int * int exception BadItyArity of itysymbol * int
exception BadRegArity of itysymbol * int * int exception BadRegArity of itysymbol * int
exception DuplicateRegion of region exception DuplicateRegion of region
exception UnboundRegion of region exception UnboundRegion of region
......
...@@ -368,8 +368,8 @@ and dpat_app denv gloc ({ de_loc = loc } as de) ppl dity = ...@@ -368,8 +368,8 @@ and dpat_app denv gloc ({ de_loc = loc } as de) ppl dity =
| DEglobal_ps ps -> errorm ~loc "%a is not a constructor" print_ps ps | DEglobal_ps ps -> errorm ~loc "%a is not a constructor" print_ps ps
| _ -> assert false in | _ -> assert false in
let argl, res = de.de_type in let argl, res = de.de_type in
if List.length argl <> List.length ppl then error ~loc:gloc if List.length argl <> List.length ppl then
(Term.BadArity (ls, List.length argl, List.length ppl)); error ~loc:gloc (Term.BadArity (ls, List.length ppl));
unify_loc unify gloc res dity; unify_loc unify gloc res dity;
let add_pp lp ty (ppl, denv) = let add_pp lp ty (ppl, denv) =
let pp, denv = dpattern denv lp ty in pp::ppl, denv in let pp, denv = dpattern denv lp ty in pp::ppl, denv in
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment