Commit efaf0dc2 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

be more stricte in accepting inductives and algebraics

1. We only accept an algebraic type declaration

    T 'a1 ... 'aN

whenever every constructor has ls_value = Some (T 'a1 ... 'aN),
no type variable renaming is allowed.

2. We only accept an inductive predicate declaration

    P (_x1 : T1) ... (_xN : TN)

whenever every inductive clause has a conclusion of the form
(P (t1 : T1) ... (tN : TN)), no type variable renaming is allowed.

3. To this purpose, we must typecheck the whole (mutual) inductive
declaration group in the same denv. This must be ok, since user-named
type variables cannot be destructively instantiated anyway. However,
I'd like Jean-Christoph to check my changes in Typing.add_inductives.
parent 5146df7c
...@@ -390,7 +390,7 @@ let create_ty_decl tdl = ...@@ -390,7 +390,7 @@ let create_ty_decl tdl =
let tss = List.fold_left add Sts.empty tdl in let tss = List.fold_left add Sts.empty tdl in
let check_constr tys ty (syms,news) fs = let check_constr tys ty (syms,news) fs =
let vty = of_option fs.ls_value in let vty = of_option fs.ls_value in
ignore (ty_match Mtv.empty vty ty); if not (ty_equal ty vty) then raise (TypeMismatch (ty,vty));
let add s ty = match ty.ty_node with let add s ty = match ty.ty_node with
| Tyvar v -> Stv.add v s | Tyvar v -> Stv.add v s
| _ -> assert false | _ -> assert false
...@@ -475,11 +475,11 @@ let create_ind_decl idl = ...@@ -475,11 +475,11 @@ let create_ind_decl idl =
let cls, f = clause [] (check_fvs f) in let cls, f = clause [] (check_fvs f) in
match f.f_node with match f.f_node with
| Fapp (s, tl) when ls_equal s ps -> | Fapp (s, tl) when ls_equal s ps ->
let mtch sb t ty = let mtch t ty =
try ty_match sb (t.t_ty) ty with TypeMismatch _ -> if not (ty_equal t.t_ty ty) then
raise (TooSpecificIndDecl (ps, pr, t)) raise (TooSpecificIndDecl (ps, pr, t))
in in
ignore (List.fold_left2 mtch Mtv.empty tl ps.ls_args); List.iter2 mtch tl ps.ls_args;
(try ignore (List.for_all (f_pos_ps sps (Some true)) cls) (try ignore (List.for_all (f_pos_ps sps (Some true)) cls)
with Found ls -> raise (NonPositiveIndDecl (ps, pr, ls))); with Found ls -> raise (NonPositiveIndDecl (ps, pr, ls)));
syms_fmla syms f, news_id news pr.pr_name syms_fmla syms f, news_id news pr.pr_name
......
...@@ -1023,11 +1023,10 @@ let f_pred_app_l pr tl = match List.rev tl with ...@@ -1023,11 +1023,10 @@ let f_pred_app_l pr tl = match List.rev tl with
| _ -> Pervasives.invalid_arg "f_pred_app_l" | _ -> Pervasives.invalid_arg "f_pred_app_l"
let fs_tuple = Util.memo_int 17 (fun n -> let fs_tuple = Util.memo_int 17 (fun n ->
let tyl = ref [] in let ts = ts_tuple n in
for i = 1 to n let tl = List.map ty_var ts.ts_args in
do tyl := ty_var (create_tvsymbol (id_fresh "a")) :: !tyl done; let ty = ty_app ts tl in
let ty = ty_tuple !tyl in create_fsymbol (id_fresh ("Tuple" ^ string_of_int n)) tl ty)
create_fsymbol (id_fresh ("Tuple" ^ string_of_int n)) !tyl ty)
let is_fs_tuple fs = fs == fs_tuple (List.length fs.ls_args) let is_fs_tuple fs = fs == fs_tuple (List.length fs.ls_args)
......
...@@ -872,17 +872,13 @@ let type_term denv env t = ...@@ -872,17 +872,13 @@ let type_term denv env t =
let t = dterm denv t in let t = dterm denv t in
term env t term env t
let term uc = type_term (create_denv uc) Mstr.empty
let type_fmla denv env f = let type_fmla denv env f =
let f = dfmla denv f in let f = dfmla denv f in
fmla env f fmla env f
let fmla uc = type_fmla (create_denv uc) Mstr.empty
let add_prop k loc s f th = let add_prop k loc s f th =
let pr = create_prsymbol (id_user ~labels:s.id_lab s.id loc) in let pr = create_prsymbol (id_user ~labels:s.id_lab s.id loc) in
try add_prop_decl th k pr (fmla th f) try add_prop_decl th k pr (type_fmla (create_denv th) Mstr.empty f)
with ClashSymbol s -> error ~loc (Clash s) with ClashSymbol s -> error ~loc (Clash s)
let loc_of_id id = match id.id_origin with let loc_of_id id = match id.id_origin with
...@@ -891,11 +887,11 @@ let loc_of_id id = match id.id_origin with ...@@ -891,11 +887,11 @@ let loc_of_id id = match id.id_origin with
let add_inductives dl th = let add_inductives dl th =
(* 1. create all symbols and make an environment with these symbols *) (* 1. create all symbols and make an environment with these symbols *)
let denv = create_denv th in
let psymbols = Hashtbl.create 17 in let psymbols = Hashtbl.create 17 in
let create_symbol th d = let create_symbol th d =
let id = d.in_ident.id in let id = d.in_ident.id in
let v = id_user ~labels:d.in_ident.id_lab id d.in_loc in let v = id_user ~labels:d.in_ident.id_lab id d.in_loc in
let denv = create_denv th in
let type_ty (_,t) = ty_of_dty (dty denv t) in let type_ty (_,t) = ty_of_dty (dty denv t) in
let pl = List.map type_ty d.in_params in let pl = List.map type_ty d.in_params in
let ps = create_psymbol v pl in let ps = create_psymbol v pl in
...@@ -904,6 +900,7 @@ let add_inductives dl th = ...@@ -904,6 +900,7 @@ let add_inductives dl th =
with ClashSymbol s -> error ~loc:d.in_loc (Clash s) with ClashSymbol s -> error ~loc:d.in_loc (Clash s)
in in
let th' = List.fold_left create_symbol th dl in let th' = List.fold_left create_symbol th dl in
let denv = { denv with uc = th' } in
(* 2. then type-check all definitions *) (* 2. then type-check all definitions *)
let propsyms = Hashtbl.create 17 in let propsyms = Hashtbl.create 17 in
let type_decl d = let type_decl d =
...@@ -911,7 +908,8 @@ let add_inductives dl th = ...@@ -911,7 +908,8 @@ let add_inductives dl th =
let ps = Hashtbl.find psymbols id in let ps = Hashtbl.find psymbols id in
let clause (loc, { id = id ; id_lab = labels }, f) = let clause (loc, { id = id ; id_lab = labels }, f) =
Hashtbl.replace propsyms id loc; Hashtbl.replace propsyms id loc;
create_prsymbol (id_user ~labels id loc), fmla th' f let f = type_fmla denv Mstr.empty f in
create_prsymbol (id_user ~labels id loc), f
in in
ps, List.map clause d.in_def ps, List.map clause d.in_def
in 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