diff options
137 files changed, 4081 insertions, 3575 deletions
diff --git a/checker/check_stat.ml b/checker/check_stat.ml index 290e6ff8e..170ac6384 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -33,7 +33,7 @@ let pr_engt = function str "Theory: Set is predicative" let cst_filter f csts = - Cmap.fold + Cmap_env.fold (fun c ce acc -> if f c ce then c::acc else acc) csts [] diff --git a/checker/closure.ml b/checker/closure.ml index b55c5848e..c710df816 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -378,7 +378,7 @@ let defined_rels flags env = (rel_context env) ~init:(0,[]) (* else (0,[])*) -let mind_equiv_infos info = mind_equiv info.i_env +let mind_equiv_infos info = eq_ind let create mk_cl flgs env = { i_flags = flgs; diff --git a/checker/declarations.ml b/checker/declarations.ml index 0066e7848..3211cc28f 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -31,60 +31,241 @@ let val_cst_type = type substitution_domain = - MSI of mod_self_id | MBI of mod_bound_id | MPI of module_path let val_subst_dom = - val_sum "substitution_domain" 0 [|[|val_uid|];[|val_uid|];[|val_mp|]|] + val_sum "substitution_domain" 0 [|[|val_uid|];[|val_mp|]|] module Umap = Map.Make(struct type t = substitution_domain let compare = Pervasives.compare end) -type resolver -type substitution = (module_path * resolver option) Umap.t +type delta_hint = + Inline of constr option + | Equiv of kernel_name + | Prefix_equiv of module_path + +type delta_key = + KN of kernel_name + | MP of module_path + +module Deltamap = Map.Make(struct + type t = delta_key + let compare = Pervasives.compare + end) + +type delta_resolver = delta_hint Deltamap.t + +let empty_delta_resolver = Deltamap.empty + +type substitution = (module_path * delta_resolver) Umap.t type 'a subst_fun = substitution -> 'a -> 'a -let val_res = val_opt no_val +let val_res_dom = no_val + (*val_sum "resolver_domain" 0 [|[|val_kn|];[|val_mp|]|]*) + +let val_res = no_val + (* val_map ~name:"delta_resolver" + val_res_dom + (val_sum "resolver_codomain" 0 [|[|val_opt val_constr||];[|val_kn|];[|val_mp|]|])*) let val_subst = val_map ~name:"substitution" val_subst_dom (val_tuple "substition range" [|val_mp;val_res|]) -let fold_subst fs fb fp = +let fold_subst fb fp = Umap.fold (fun k (mp,_) acc -> match k with - MSI msid -> fs msid mp acc | MBI mbid -> fb mbid mp acc | MPI mp1 -> fp mp1 mp acc) let empty_subst = Umap.empty -let add_msid msid mp = - Umap.add (MSI msid) (mp,None) let add_mbid mbid mp = - Umap.add (MBI mbid) (mp,None) + Umap.add (MBI mbid) (mp,empty_delta_resolver) let add_mp mp1 mp2 = - Umap.add (MPI mp1) (mp2,None) + Umap.add (MPI mp1) (mp2,empty_delta_resolver) -let map_msid msid mp = add_msid msid mp empty_subst let map_mbid mbid mp = add_mbid mbid mp empty_subst let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst +let add_inline_delta_resolver con = + Deltamap.add (KN(user_con con)) (Inline None) + +let add_inline_constr_delta_resolver con cstr = + Deltamap.add (KN(user_con con)) (Inline (Some cstr)) + +let add_constant_delta_resolver con = + Deltamap.add (KN(user_con con)) (Equiv (canonical_con con)) + +let add_mind_delta_resolver mind = + Deltamap.add (KN(user_mind mind)) (Equiv (canonical_mind mind)) + +let add_mp_delta_resolver mp1 mp2 = + Deltamap.add (MP mp1) (Prefix_equiv mp2) + +let mp_in_delta mp = + Deltamap.mem (MP mp) + +let con_in_delta con resolver = +try + match Deltamap.find (KN(user_con con)) resolver with + | Inline _ | Prefix_equiv _ -> false + | Equiv _ -> true +with + Not_found -> false + +let mind_in_delta mind resolver = +try + match Deltamap.find (KN(user_mind mind)) resolver with + | Inline _ | Prefix_equiv _ -> false + | Equiv _ -> true +with + Not_found -> false + +let delta_of_mp resolve mp = + try + match Deltamap.find (MP mp) resolve with + | Prefix_equiv mp1 -> mp1 + | _ -> anomaly "mod_subst: bad association in delta_resolver" + with + Not_found -> mp + +let delta_of_kn resolve kn = + try + match Deltamap.find (KN kn) resolve with + | Equiv kn1 -> kn1 + | Inline _ -> kn + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + with + Not_found -> kn + +let remove_mp_delta_resolver resolver mp = + Deltamap.remove (MP mp) resolver + +exception Inline_kn + +let rec find_prefix resolve mp = + let rec sub_mp = function + | MPdot(mp,l) as mp_sup -> + (try + match Deltamap.find (MP mp_sup) resolve with + | Prefix_equiv mp1 -> mp1 + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + with + Not_found -> MPdot(sub_mp mp,l)) + | p -> + match Deltamap.find (MP p) resolve with + | Prefix_equiv mp1 -> mp1 + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + in + try + sub_mp mp + with + Not_found -> mp + +let solve_delta_kn resolve kn = + try + match Deltamap.find (KN kn) resolve with + | Equiv kn1 -> kn1 + | Inline _ -> raise Inline_kn + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + with + Not_found | Inline_kn -> + let mp,dir,l = repr_kn kn in + let new_mp = find_prefix resolve mp in + if mp == new_mp then + kn + else + make_kn new_mp dir l + + +let constant_of_delta resolve con = + let kn = user_con con in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + con + else + constant_of_kn_equiv kn new_kn + +let constant_of_delta2 resolve con = + let kn = canonical_con con in + let kn1 = user_con con in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + con + else + constant_of_kn_equiv kn1 new_kn + +let mind_of_delta resolve mind = + let kn = user_mind mind in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + mind + else + mind_of_kn_equiv kn new_kn + +let mind_of_delta2 resolve mind = + let kn = canonical_mind mind in + let kn1 = user_mind mind in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + mind + else + mind_of_kn_equiv kn1 new_kn + + + +let inline_of_delta resolver = + let extract key hint l = + match key,hint with + |KN kn, Inline _ -> kn::l + | _,_ -> l + in + Deltamap.fold extract resolver [] + +exception Not_inline + +let constant_of_delta_with_inline resolve con = + let kn1,kn2 = canonical_con con,user_con con in + try + match Deltamap.find (KN kn2) resolve with + | Inline None -> None + | Inline (Some const) -> Some const + | _ -> raise Not_inline + with + Not_found | Not_inline -> + try match Deltamap.find (KN kn1) resolve with + | Inline None -> None + | Inline (Some const) -> Some const + | _ -> raise Not_inline + with + Not_found | Not_inline -> None + let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with - | MPself sid -> - let mp',resolve = Umap.find (MSI sid) sub in + | MPfile sid -> + let mp',resolve = Umap.find (MPI (MPfile sid)) sub in mp',resolve | MPbound bid -> - let mp',resolve = Umap.find (MBI bid) sub in - mp',resolve + begin + try + let mp',resolve = Umap.find (MBI bid) sub in + mp',resolve + with Not_found -> + let mp',resolve = Umap.find (MPI mp) sub in + mp',resolve + end | MPdot (mp1,l) as mp2 -> begin try @@ -94,59 +275,135 @@ let subst_mp0 sub mp = (* 's like subst *) let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end - | _ -> raise Not_found in try Some (aux mp) with Not_found -> None - - -let subst_mp0 sub mp = (* 's like subst *) - let rec aux mp = - match mp with - | MPself sid -> fst (Umap.find (MSI sid) sub) - | MPbound bid -> fst (Umap.find (MBI bid) sub) - | MPdot (mp1,l) as mp2 -> - begin - try fst (Umap.find (MPI mp2) sub) - with Not_found -> MPdot (aux mp1,l) - end - - | _ -> raise Not_found - in - try Some (aux mp) with Not_found -> None - let subst_mp sub mp = match subst_mp0 sub mp with None -> mp - | Some mp' -> mp' + | Some (mp',_) -> mp' -let subst_kn0 sub kn = +let subst_kn_delta sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with - Some mp' -> - Some (make_kn mp' dir l) - | None -> None + Some (mp',resolve) -> + solve_delta_kn resolve (make_kn mp' dir l) + | None -> kn let subst_kn sub kn = - match subst_kn0 sub kn with - None -> kn - | Some kn' -> kn' + let mp,dir,l = repr_kn kn in + match subst_mp0 sub mp with + Some (mp',_) -> + make_kn mp' dir l + | None -> kn + +exception No_subst + +type sideconstantsubst = + | User + | Canonical + +let subst_ind sub mind = + let kn1,kn2 = user_mind mind,canonical_mind mind in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,mind',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_mind_equiv mp1' mp2' dir l), resolve2 + in + match side with + |User -> + let mind = mind_of_delta resolve mind' in + mind + |Canonical -> + let mind = mind_of_delta2 resolve mind' in + mind + with + No_subst -> mind + +let subst_mind0 sub mind = + let kn1,kn2 = user_mind mind,canonical_mind mind in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,mind',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_mind_equiv mp1' mp2' dir l), resolve2 + in + match side with + |User -> + let mind = mind_of_delta resolve mind' in + Some mind + |Canonical -> + let mind = mind_of_delta2 resolve mind' in + Some mind + with + No_subst -> Some mind let subst_con sub con = - let mp,dir,l = repr_con con in - match subst_mp0 sub mp with - None -> con - | Some mp' -> make_con mp' dir l + let kn1,kn2 = user_con con,canonical_con con in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,con',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_con_equiv mp1' mp2' dir l), resolve2 + in + match constant_of_delta_with_inline resolve con' with + None -> begin + match side with + |User -> + let con = constant_of_delta resolve con' in + con,Const con + |Canonical -> + let con = constant_of_delta2 resolve con' in + con,Const con + end + | Some t -> con',t + with No_subst -> con , Const con + let subst_con0 sub con = - let mp,dir,l = repr_con con in - match subst_mp0 sub mp with - None -> None - | Some mp' -> - let con' = make_con mp' dir l in - Some (Const con') + let kn1,kn2 = user_con con,canonical_con con in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,con',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_con_equiv mp1' mp2' dir l), resolve2 + in + match constant_of_delta_with_inline resolve con' with + None ->begin + match side with + |User -> + let con = constant_of_delta resolve con' in + Some (Const con) + |Canonical -> + let con = constant_of_delta2 resolve con' in + Some (Const con) + end + | t -> t + with No_subst -> Some (Const con) + let rec map_kn f f' c = let func = map_kn f f' in @@ -220,22 +477,8 @@ let rec map_kn f f' c = | _ -> c let subst_mps sub = - map_kn (subst_kn0 sub) (subst_con0 sub) + map_kn (subst_mind0 sub) (subst_con0 sub) -let rec replace_mp_in_mp mpfrom mpto mp = - match mp with - | _ when mp = mpfrom -> mpto - | MPdot (mp1,l) -> - let mp1' = replace_mp_in_mp mpfrom mpto mp1 in - if mp1==mp1' then mp - else MPdot (mp1',l) - | _ -> mp - -let replace_mp_in_con mpfrom mpto kn = - let mp,dir,l = kn in - let mp'' = replace_mp_in_mp mpfrom mpto mp in - if mp==mp'' then kn - else (mp'', dir, l) type 'a lazy_subst = | LSval of 'a @@ -253,117 +496,115 @@ let force fsubst r = r := LSval a'; a' - - -let join (subst1 : substitution) (subst2 : substitution) = - let apply_subst (sub : substitution) key (mp,_) = - match subst_mp0 sub mp with - None -> mp,None - | Some mp' -> mp',None in - let subst = Umap.mapi (apply_subst subst2) subst1 in - (Umap.fold Umap.add subst2 subst) - -let subst_key subst1 subst2 = - let replace_in_key key mp sub= - let newkey = - match key with - | MPI mp1 -> - begin - match subst_mp0 subst1 mp1 with - | None -> None - | Some mp2 -> Some (MPI mp2) - end - | _ -> None - in - match newkey with - | None -> Umap.add key mp sub - | Some mpi -> Umap.add mpi mp sub +let mp_in_key mp key = + let rec mp_rec mp1 = + match mp1 with + | _ when mp1 = mp -> true + | MPdot (mp2,l) -> mp_rec mp2 + | _ -> false + in + match key with + | MP mp1 -> + mp_rec mp1 + | KN kn -> + let mp1,dir,l = repr_kn kn in + mp_rec mp1 + +let subset_prefixed_by mp resolver = + let prefixmp key hint resolv = + if mp_in_key mp key then + Deltamap.add key hint resolv + else + resolv in - Umap.fold replace_in_key subst2 empty_subst - -let update_subst_alias subst1 subst2 = - let subst_inv key (mp,_) sub = - let newmp = - match key with - | MBI msid -> Some (MPbound msid) - | MSI msid -> Some (MPself msid) - | _ -> None - in - match newmp with - | None -> sub - | Some mpi -> match mp with - | MPbound mbid -> Umap.add (MBI mbid) (mpi,None) sub - | MPself msid -> Umap.add (MSI msid) (mpi,None) sub - | _ -> Umap.add (MPI mp) (mpi,None) sub + Deltamap.fold prefixmp resolver empty_delta_resolver + +let subst_dom_delta_resolver subst resolver = + let apply_subst key hint resolver = + match key with + (MP mp) -> + Deltamap.add (MP (subst_mp subst mp)) hint resolver + | (KN kn) -> + Deltamap.add (KN (subst_kn subst kn)) hint resolver in - let subst_mbi = Umap.fold subst_inv subst2 empty_subst in - let alias_subst key (mp,_) sub= - let newkey = - match key with - | MPI mp1 -> - begin - match subst_mp0 subst_mbi mp1 with - | None -> None - | Some mp2 -> Some (MPI mp2) - end - | _ -> None - in - match newkey with - | None -> Umap.add key (mp,None) sub - | Some mpi -> Umap.add mpi (mp,None) sub - in - Umap.fold alias_subst subst1 empty_subst + Deltamap.fold apply_subst resolver empty_delta_resolver -let join_alias (subst1 : substitution) (subst2 : substitution) = - let apply_subst (sub : substitution) key (mp,_) = - match subst_mp0 sub mp with - None -> mp,None - | Some mp' -> mp',None in - Umap.mapi (apply_subst subst2) subst1 - - -let update_subst subst1 subst2 = - let subst_inv key (mp,_) l = - let newmp = - match key with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - match mp with - | MPbound mbid -> ((MBI mbid),newmp)::l - | MPself msid -> ((MSI msid),newmp)::l - | _ -> ((MPI mp),newmp)::l +let subst_mp_delta sub mp key= + match subst_mp0 sub mp with + None -> empty_delta_resolver,mp + | Some (mp',resolve) -> + let mp1 = find_prefix resolve mp' in + let resolve1 = subset_prefixed_by mp1 resolve in + match key with + MP mpk -> + (subst_dom_delta_resolver + (map_mp mp1 mpk) resolve1),mp1 + | _ -> anomaly "Mod_subst: Bad association in resolver" + +let subst_codom_delta_resolver subst resolver = + let apply_subst key hint resolver = + match hint with + Prefix_equiv mp -> + let derived_resolve,mpnew = subst_mp_delta subst mp key in + Deltamap.fold Deltamap.add derived_resolve + (Deltamap.add key (Prefix_equiv mpnew) resolver) + | (Equiv kn) -> + Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver + | Inline None -> + Deltamap.add key hint resolver + | Inline (Some t) -> + Deltamap.add key (Inline (Some (subst_mps subst t))) resolver in - let subst_mbi = Umap.fold subst_inv subst2 [] in - let alias_subst key (mp,_) sub= - let newsetkey = - match key with - | MPI mp1 -> - let compute_set_newkey l (k,mp') = - let mp_from_key = match k with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - let new_mp1 = replace_mp_in_mp mp_from_key mp' mp1 in - if new_mp1 == mp1 then l else (MPI new_mp1)::l - in - begin - match List.fold_left compute_set_newkey [] subst_mbi with - | [] -> None - | l -> Some (l) - end - | _ -> None + Deltamap.fold apply_subst resolver empty_delta_resolver + +let subst_dom_codom_delta_resolver subst resolver = + subst_dom_delta_resolver subst + (subst_codom_delta_resolver subst resolver) + +let update_delta_resolver resolver1 resolver2 = + let apply_res key hint res = + try + match hint with + Prefix_equiv mp -> + let new_hint = + Prefix_equiv (find_prefix resolver2 mp) + in Deltamap.add key new_hint res + | Equiv kn -> + let new_hint = + Equiv (solve_delta_kn resolver2 kn) + in Deltamap.add key new_hint res + | _ -> Deltamap.add key hint res + with not_found -> + Deltamap.add key hint res in - match newsetkey with - | None -> sub - | Some l -> - List.fold_left (fun s k -> Umap.add k (mp,None) s) - sub l - in - Umap.fold alias_subst subst1 empty_subst + Deltamap.fold apply_res resolver1 empty_delta_resolver + +let add_delta_resolver resolver1 resolver2 = + if resolver1 == resolver2 then + resolver2 + else + Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2) + resolver2 +let join (subst1 : substitution) (subst2 : substitution) = + let apply_subst (sub : substitution) key (mp,resolve) = + let mp',resolve' = + match subst_mp0 sub mp with + None -> mp, None + | Some (mp',resolve') -> mp' + ,Some resolve' in + let resolve'' : delta_resolver = + match resolve' with + Some res -> + add_delta_resolver + (subst_dom_codom_delta_resolver sub resolve) + res + | None -> + subst_codom_delta_resolver sub resolve + in + mp',resolve'' in + let subst = Umap.mapi (apply_subst subst2) subst1 in + (Umap.fold Umap.add subst2 subst) let subst_substituted s r = match !r with @@ -414,7 +655,7 @@ let val_recarg = val_sum "recarg" 1 (* Norec *) let subst_recarg sub r = match r with | Norec | Mrec _ -> r - | Imbr (kn,i) -> let kn' = subst_kn sub kn in + | Imbr (kn,i) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) type wf_paths = recarg Rtree.t @@ -547,8 +788,6 @@ type mutual_inductive_body = { (* Universes constraints enforced by the inductive declaration *) mind_constraints : Univ.constraints; - (* Source of the inductive block when aliased in a module *) - mind_equiv : kernel_name option } let val_ind_pack = val_tuple "mutual_inductive_body" [|val_array val_one_ind;val_bool;val_bool;val_int;val_nctxt; @@ -605,8 +844,7 @@ let subst_mind sub mib = mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; - mind_constraints = mib.mind_constraints ; - mind_equiv = Option.map (subst_kn sub) mib.mind_equiv } + mind_constraints = mib.mind_constraints } (* Modules *) @@ -616,7 +854,6 @@ type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option * Univ.constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -624,116 +861,120 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBstruct of mod_self_id * structure_body - | SEBapply of struct_expr_body * struct_expr_body - * Univ.constraints + | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints + | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path * - struct_expr_body option * Univ.constraints + With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body and module_body = - { mod_expr : struct_expr_body option; - mod_type : struct_expr_body option; + { mod_mp : module_path; + mod_expr : struct_expr_body option; + mod_type : struct_expr_body; + mod_type_alg : struct_expr_body option; mod_constraints : Univ.constraints; - mod_alias : substitution; + mod_delta : delta_resolver; mod_retroknowledge : action list} and module_type_body = - { typ_expr : struct_expr_body; - typ_strength : module_path option; - typ_alias : substitution} + { typ_mp : module_path; + typ_expr : struct_expr_body; + typ_expr_alg : struct_expr_body option ; + typ_constraints : Univ.constraints; + typ_delta :delta_resolver} (* the validation functions: *) let rec val_sfb o = val_sum "struct_field_body" 0 [|[|val_cb|]; (* SFBconst *) [|val_ind_pack|]; (* SFBmind *) [|val_module|]; (* SFBmodule *) - [|val_mp;val_opt val_seb;val_opt val_cstrs|]; (* SFBalias *) [|val_modtype|] (* SFBmodtype *) |] o and val_sb o = val_list (val_tuple"label*sfb"[|val_id;val_sfb|]) o and val_seb o = val_sum "struct_expr_body" 0 [|[|val_mp|]; (* SEBident *) [|val_uid;val_modtype;val_seb|]; (* SEBfunctor *) - [|val_uid;val_sb|]; (* SEBstruct *) + [|val_sb|]; (* SEBstruct *) [|val_seb;val_seb;val_cstrs|]; (* SEBapply *) [|val_seb;val_with|] (* SEBwith *) |] o and val_with o = val_sum "with_declaration_body" 0 - [|[|val_list val_id;val_mp;val_cstrs|]; + [|[|val_list val_id;val_mp|]; [|val_list val_id;val_cb|]|] o and val_module o = val_tuple "module_body" - [|val_opt val_seb;val_opt val_seb;val_cstrs;val_subst;no_val|] o + [|val_mp;val_opt val_seb;val_opt val_seb; + val_seb;val_cstrs;val_res;no_val|] o and val_modtype o = val_tuple "module_type_body" - [|val_seb;val_opt val_mp;val_subst|] o + [|val_mp;val_seb;val_opt val_seb;val_cstrs;val_res|] o let rec subst_with_body sub = function - | With_module_body(id,mp,typ_opt,cst) -> - With_module_body(id,subst_mp sub mp, - Option.smartmap (subst_struct_expr sub) typ_opt,cst) + | With_module_body(id,mp) -> + With_module_body(id,subst_mp sub mp) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) -and subst_modtype sub mtb = +and subst_modtype sub mtb= let typ_expr' = subst_struct_expr sub mtb.typ_expr in - if typ_expr'==mtb.typ_expr then - mtb + let typ_alg' = + Option.smartmap + (subst_struct_expr sub) mtb.typ_expr_alg in + let mp = subst_mp sub mtb.typ_mp + in + if typ_expr'==mtb.typ_expr && + typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then + mtb else - { mtb with - typ_expr = typ_expr'} - -and subst_structure sub sign = - let subst_body = function - SFBconst cb -> + {mtb with + typ_mp = mp; + typ_expr = typ_expr'; + typ_expr_alg = typ_alg'} + +and subst_structure sub sign = + let subst_body = function + SFBconst cb -> SFBconst (subst_const_body sub cb) - | SFBmind mib -> + | SFBmind mib -> SFBmind (subst_mind sub mib) - | SFBmodule mb -> - SFBmodule (subst_module sub mb) - | SFBmodtype mtb -> + | SFBmodule mb -> + SFBmodule (subst_module sub mb) + | SFBmodtype mtb -> SFBmodtype (subst_modtype sub mtb) - | SFBalias (mp,typ_opt ,cst) -> - SFBalias (subst_mp sub mp, - Option.smartmap (subst_struct_expr sub) typ_opt,cst) in List.map (fun (l,b) -> (l,subst_body b)) sign -and subst_module sub mb = - let mtb' = Option.smartmap (subst_struct_expr sub) mb.mod_type in - (* This is similar to the previous case. In this case we have - a module M in a signature that is knows to be equivalent to a module M' - (because the signature is "K with Module M := M'") and we are substituting - M' with some M''. *) - let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in - let mb_alias = join_alias mb.mod_alias sub in - if mtb'==mb.mod_type && mb.mod_expr == me' - && mb_alias == mb.mod_alias - then mb else - { mod_expr = me'; - mod_type=mtb'; - mod_constraints=mb.mod_constraints; - mod_alias = mb_alias; - mod_retroknowledge=mb.mod_retroknowledge} +and subst_module sub mb = + let mtb' = subst_struct_expr sub mb.mod_type in + let typ_alg' = Option.smartmap + (subst_struct_expr sub ) mb.mod_type_alg in + let me' = Option.smartmap + (subst_struct_expr sub) mb.mod_expr in + let mp = subst_mp sub mb.mod_mp in + if mtb'==mb.mod_type && mb.mod_expr == me' + && mp == mb.mod_mp + then mb else + { mb with + mod_mp = mp; + mod_expr = me'; + mod_type_alg = typ_alg'; + mod_type=mtb'} and subst_struct_expr sub = function - | SEBident mp -> SEBident (subst_mp sub mp) - | SEBfunctor (msid, mtb, meb') -> - SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb') - | SEBstruct (msid,str)-> - SEBstruct(msid, subst_structure sub str) + | SEBident mp -> SEBident (subst_mp sub mp) + | SEBfunctor (mbid, mtb, meb') -> + SEBfunctor(mbid,subst_modtype sub mtb + ,subst_struct_expr sub meb') + | SEBstruct (str)-> + SEBstruct( subst_structure sub str) | SEBapply (meb1,meb2,cst)-> SEBapply(subst_struct_expr sub meb1, subst_struct_expr sub meb2, cst) - | SEBwith (meb,wdb)-> + | SEBwith (meb,wdb)-> SEBwith(subst_struct_expr sub meb, subst_with_body sub wdb) -let subst_signature_msid msid mp = - subst_structure (map_msid msid mp) diff --git a/checker/declarations.mli b/checker/declarations.mli index 3d061b4c2..bae7da908 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -141,19 +141,18 @@ type mutual_inductive_body = { (* Universes constraints enforced by the inductive declaration *) mind_constraints : Univ.constraints; - (* Source of the inductive block when aliased in a module *) - mind_equiv : kernel_name option } (* Modules *) type substitution +type delta_resolver +val empty_delta_resolver : delta_resolver type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option * Univ.constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -161,32 +160,33 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBstruct of mod_self_id * structure_body - | SEBapply of struct_expr_body * struct_expr_body - * Univ.constraints + | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints + | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path * - struct_expr_body option * Univ.constraints + With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body and module_body = - { mod_expr : struct_expr_body option; - mod_type : struct_expr_body option; + { mod_mp : module_path; + mod_expr : struct_expr_body option; + mod_type : struct_expr_body; + mod_type_alg : struct_expr_body option; mod_constraints : Univ.constraints; - mod_alias : substitution; + mod_delta : delta_resolver; mod_retroknowledge : action list} and module_type_body = - { typ_expr : struct_expr_body; - typ_strength : module_path option; - typ_alias : substitution} + { typ_mp : module_path; + typ_expr : struct_expr_body; + typ_expr_alg : struct_expr_body option ; + typ_constraints : Univ.constraints; + typ_delta :delta_resolver} (* Substitutions *) val fold_subst : - (mod_self_id -> module_path -> 'a -> 'a) -> (mod_bound_id -> module_path -> 'a -> 'a) -> (module_path -> module_path -> 'a -> 'a) -> substitution -> 'a -> 'a @@ -194,10 +194,8 @@ val fold_subst : type 'a subst_fun = substitution -> 'a -> 'a val empty_subst : substitution -val add_msid : mod_self_id -> module_path -> substitution -> substitution val add_mbid : mod_bound_id -> module_path -> substitution -> substitution val add_mp : module_path -> module_path -> substitution -> substitution -val map_msid : mod_self_id -> module_path -> substitution val map_mbid : mod_bound_id -> module_path -> substitution val map_mp : module_path -> module_path -> substitution @@ -206,14 +204,9 @@ val subst_mind : mutual_inductive_body subst_fun val subst_modtype : substitution -> module_type_body -> module_type_body val subst_struct_expr : substitution -> struct_expr_body -> struct_expr_body val subst_structure : substitution -> structure_body -> structure_body -val subst_signature_msid : - mod_self_id -> module_path -> structure_body -> structure_body +val subst_module : substitution -> module_body -> module_body val join : substitution -> substitution -> substitution -val join_alias : substitution -> substitution -> substitution -val update_subst_alias : substitution -> substitution -> substitution -val update_subst : substitution -> substitution -> substitution -val subst_key : substitution -> substitution -> substitution (* Validation *) val val_eng : Obj.t -> unit diff --git a/checker/environ.ml b/checker/environ.ml index 2d5ff3e43..3d14b995b 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -5,11 +5,10 @@ open Term open Declarations type globals = { - env_constants : constant_body Cmap.t; - env_inductives : mutual_inductive_body KNmap.t; + env_constants : constant_body Cmap_env.t; + env_inductives : mutual_inductive_body Mindmap_env.t; env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t; - env_alias : module_path MPmap.t } + env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : universes; @@ -25,11 +24,10 @@ type env = { let empty_env = { env_globals = - { env_constants = Cmap.empty; - env_inductives = KNmap.empty; + { env_constants = Cmap_env.empty; + env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; - env_modtypes = MPmap.empty; - env_alias = MPmap.empty }; + env_modtypes = MPmap.empty}; env_named_context = []; env_rel_context = []; env_stratification = @@ -108,11 +106,11 @@ let add_constraints c env = (* Global constants *) let lookup_constant kn env = - Cmap.find kn env.env_globals.env_constants + Cmap_env.find kn env.env_globals.env_constants let add_constant kn cs env = let new_constants = - Cmap.add kn cs env.env_globals.env_constants in + Cmap_env.add kn cs env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in @@ -145,26 +143,15 @@ let evaluable_constant cst env = (* Mutual Inductives *) let lookup_mind kn env = - KNmap.find kn env.env_globals.env_inductives - -let rec scrape_mind env kn = - match (lookup_mind kn env).mind_equiv with - | None -> kn - | Some kn' -> scrape_mind env kn' + Mindmap_env.find kn env.env_globals.env_inductives let add_mind kn mib env = - let new_inds = KNmap.add kn mib env.env_globals.env_inductives in + let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let new_globals = { env.env_globals with env_inductives = new_inds } in { env with env_globals = new_globals } -let rec mind_equiv env (kn1,i1) (kn2,i2) = - let rec equiv kn1 kn2 = - kn1 = kn2 || - scrape_mind env kn1 = scrape_mind env kn2 in - i1 = i2 && equiv kn1 kn2 - (* Modules *) @@ -182,19 +169,6 @@ let shallow_add_module mp mb env = env_modules = new_mods } in { env with env_globals = new_globals } -let register_alias mp1 mp2 env = - let new_alias = MPmap.add mp1 mp2 env.env_globals.env_alias in - let new_globals = - { env.env_globals with - env_alias = new_alias } in - { env with env_globals = new_globals } - -let rec scrape_alias mp env = - try - let mp1 = MPmap.find mp env.env_globals.env_alias in - scrape_alias mp1 env - with - Not_found -> mp let lookup_module mp env = MPmap.find mp env.env_globals.env_modules diff --git a/checker/environ.mli b/checker/environ.mli index 1541bf0d8..776698ed8 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -4,12 +4,10 @@ open Term (* Environments *) type globals = { - env_constants : Declarations.constant_body Cmap.t; - env_inductives : Declarations.mutual_inductive_body KNmap.t; + env_constants : Declarations.constant_body Cmap_env.t; + env_inductives : Declarations.mutual_inductive_body Mindmap_env.t; env_modules : Declarations.module_body MPmap.t; - env_modtypes : Declarations.module_type_body MPmap.t; - env_alias : module_path MPmap.t; -} + env_modtypes : Declarations.module_type_body MPmap.t} type stratification = { env_universes : Univ.universes; env_engagement : Declarations.engagement option; @@ -61,17 +59,14 @@ val evaluable_constant : constant -> env -> bool (* Inductives *) val lookup_mind : mutual_inductive -> env -> Declarations.mutual_inductive_body -val scrape_mind : env -> mutual_inductive -> mutual_inductive + val add_mind : mutual_inductive -> Declarations.mutual_inductive_body -> env -> env -val mind_equiv : env -> inductive -> inductive -> bool (* Modules *) val add_modtype : module_path -> Declarations.module_type_body -> env -> env val shallow_add_module : module_path -> Declarations.module_body -> env -> env -val register_alias : module_path -> module_path -> env -> env -val scrape_alias : module_path -> env -> module_path val lookup_module : module_path -> env -> Declarations.module_body val lookup_modtype : module_path -> env -> Declarations.module_type_body diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 3d4f6be79..e0aa9e7c3 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -22,13 +22,11 @@ open Environ let rec debug_string_of_mp = function | MPfile sl -> string_of_dirpath sl | MPbound uid -> "bound("^string_of_mbid uid^")" - | MPself uid -> "self("^string_of_msid uid^")" | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l let rec string_of_mp = function | MPfile sl -> string_of_dirpath sl | MPbound uid -> string_of_mbid uid - | MPself uid -> string_of_msid uid | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l let string_of_mp mp = @@ -515,7 +513,7 @@ let check_positivity env_ar params nrecp inds = (************************************************************************) let check_inductive env kn mib = - Flags.if_verbose msgnl (str " checking ind: " ++ prkn kn); + Flags.if_verbose msgnl (str " checking ind: " ++ pr_mind kn); (* check mind_constraints: should be consistent with env *) let env = add_constraints mib.mind_constraints env in (* check mind_record : TODO ? check #constructor = 1 ? *) @@ -540,8 +538,6 @@ let check_inductive env kn mib = (* check mind_nparams_rec: positivity condition *) check_positivity env_ar params mib.mind_nparams_rec mib.mind_packets; (* check mind_equiv... *) - if mib.mind_equiv <> None then - msg_warning (str"TODO: mind_equiv not checked"); (* Now we can add the inductive *) add_mind kn mib env diff --git a/checker/inductive.ml b/checker/inductive.ml index e08efbe5b..19c7a6cfe 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -351,7 +351,7 @@ let type_case_branches env (ind,largs) (p,pj) c = let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if - not (mind_equiv env indsp ci.ci_ind) or + not (eq_ind indsp ci.ci_ind) or (mib.mind_nparams <> ci.ci_npar) or (mip.mind_consnrealdecls <> ci.ci_cstr_nargs) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 99babe632..e95109fc5 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -65,10 +65,6 @@ let rec list_fold_map2 f e = function let e'',t1',t2' = list_fold_map2 f e' t in e'',h1'::t1',h2'::t2' - -let check_alias (s1:substitution) s2 = - if s1 <> s2 then failwith "Incorrect alias" - let check_definition_sub env cb1 cb2 = let check_type env t1 t2 = @@ -135,31 +131,31 @@ let lookup_modtype mp env = with Not_found -> failwith ("Unknown module type: "^string_of_mp mp) - -let rec check_with env mtb with_decl = +let rec check_with env mtb with_decl mp= match with_decl with | With_definition_body _ -> - check_with_aux_def env mtb with_decl; - empty_subst + check_with_aux_def env mtb with_decl mp; + mtb | With_module_body _ -> - check_with_aux_mod env mtb with_decl + check_with_aux_mod env mtb with_decl mp; + mtb -and check_with_aux_def env mtb with_decl = - let msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) -> - msid,sig_b +and check_with_aux_def env mtb with_decl mp = + let sig_b = match mtb with + | SEBstruct(sig_b) -> + sig_b | _ -> error_signature_expected mtb in let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> + | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> id,idl - | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false + | With_definition_body ([],_) | With_module_body ([],_) -> assert false in let l = label_of_id id in try let rev_before,spec,after = list_split_assoc l [] sig_b in let before = List.rev rev_before in - let env' = Modops.add_signature (MPself msid) before env in + let env' = Modops.add_signature mp before empty_delta_resolver env in match with_decl with | With_definition_body ([],_) -> assert false | With_definition_body ([id],c) -> @@ -179,9 +175,9 @@ and check_with_aux_def env mtb with_decl = let new_with_decl = match with_decl with With_definition_body (_,c) -> With_definition_body (idl,c) - | With_module_body (_,c,t,cst) -> - With_module_body (idl,c,t,cst) in - check_with_aux_def env' (type_of_mb env old) new_with_decl + | With_module_body (_,c) -> + With_module_body (idl,c) in + check_with_aux_def env' old.mod_type new_with_decl (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end @@ -190,46 +186,35 @@ and check_with_aux_def env mtb with_decl = Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl = - let initmsid,msid,sig_b = - match eval_struct env mtb with - | SEBstruct(msid,sig_b) -> - let msid'=(refresh_msid msid) in - msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b) +and check_with_aux_mod env mtb with_decl mp = + let sig_b = + match mtb with + | SEBstruct(sig_b) -> + sig_b | _ -> error_signature_expected mtb in let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> + | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> id,idl - | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false + | With_definition_body ([],_) | With_module_body ([],_) -> assert false in let l = label_of_id id in try let rev_before,spec,after = list_split_assoc l [] sig_b in let before = List.rev rev_before in let rec mp_rec = function - | [] -> MPself initmsid + | [] -> mp | i::r -> MPdot(mp_rec r,label_of_id i) in - let env' = Modops.add_signature (MPself msid) before env in + let env' = Modops.add_signature mp before empty_delta_resolver env in match with_decl with - | With_module_body ([],_,_,_) -> assert false - | With_module_body ([id], mp,_,_) -> - let old,alias = match spec with - SFBmodule msb -> Some msb,None - | SFBalias (mp',_,_) -> None,Some mp' + | With_module_body ([],_) -> assert false + | With_module_body ([id], mp1) -> + let _ = match spec with + SFBmodule msb -> msb | _ -> error_not_a_module l in - let mtb' = lookup_modtype mp env' in - let _ = - match old,alias with - Some msb,None -> () - | None,Some mp' -> - check_modpath_equiv env' mp mp' - | _,_ -> - anomaly "Mod_typing:no implementation and no alias" - in - join (map_mp (mp_rec [id]) mp) mtb'.typ_alias - | With_module_body (_::_,mp,_,_) -> + let _ = (lookup_module mp1 env) in () + | With_module_body (_::_,mp) -> let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -240,12 +225,10 @@ and check_with_aux_mod env mtb with_decl = let new_with_decl = match with_decl with With_definition_body (_,c) -> With_definition_body (idl,c) - | With_module_body (_,c,t,cst) -> - With_module_body (idl,c,t,cst) in - let sub = - check_with_aux_mod env' - (type_of_mb env old) new_with_decl in - join (map_mp (mp_rec idl) mp) sub + | With_module_body (_,c) -> + With_module_body (idl,c) in + check_with_aux_mod env' + old.mod_type new_with_decl (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end @@ -255,110 +238,105 @@ and check_with_aux_mod env mtb with_decl = | Reduction.NotConvertible -> error_with_incorrect l and check_module_type env mty = - if mty.typ_strength <> None then - failwith "strengthening of module types not supported"; - let sub = check_modexpr env mty.typ_expr in - check_alias mty.typ_alias sub - -and check_module env mb = - let sub = - match mb.mod_expr, mb.mod_type with - | None, None -> - anomaly "Mod_typing.translate_module: empty type and expr in module entry" - | None, Some mtb -> check_modexpr env mtb - - | Some mexpr, _ -> - let sub1 = check_modexpr env mexpr in - (match mb.mod_type with - | None -> sub1 - | Some mte -> - let sub2 = check_modexpr env mte in - check_subtypes env - {typ_expr = mexpr; - typ_strength = None; - typ_alias = sub1;} - {typ_expr = mte; - typ_strength = None; - typ_alias = sub2;}; - sub2) in - check_alias mb.mod_alias sub - -and check_structure_field (s,env) mp lab = function + let _ = check_modtype env mty.typ_expr mty.typ_mp in () + + +and check_module env mp mb = + match mb.mod_expr, mb.mod_type with + | None,mtb -> + let _ = check_modtype env mtb mb.mod_mp in () + | Some mexpr, _ -> + let sign = check_modexpr env mexpr mb.mod_mp in + let _ = check_modtype env mb.mod_type mb.mod_mp in + check_subtypes env + {typ_mp=mp; + typ_expr=sign; + typ_expr_alg=None; + typ_constraints=Univ.Constraint.empty; + typ_delta = empty_delta_resolver;} + {typ_mp=mp; + typ_expr=mb.mod_type; + typ_expr_alg=None; + typ_constraints=Univ.Constraint.empty; + typ_delta = empty_delta_resolver;}; + +and check_structure_field env mp lab = function | SFBconst cb -> let c = make_con mp empty_dirpath lab in - (s,check_constant_declaration env c cb) + check_constant_declaration env c cb | SFBmind mib -> - let kn = make_kn mp empty_dirpath lab in - (s,Indtypes.check_inductive env kn mib) + let kn = make_mind mp empty_dirpath lab in + Indtypes.check_inductive env kn mib | SFBmodule msb -> - check_module env msb; - let mp1 = MPdot(mp,lab) in - let is_fun, sub = Modops.update_subst env msb mp1 in - ((if is_fun then s else join s sub), - Modops.add_module (MPdot(mp,lab)) msb env) - | SFBalias(mp2,_,cst) -> - (* cf Safe_typing.add_alias *) - (try - let mp' = MPdot(mp,lab) in - let mp2' = scrape_alias mp2 env in - let _,sub = Modops.update_subst env (lookup_module mp2' env) mp2' in - let sub = update_subst sub (map_mp mp' mp2') in - let sub = join_alias sub (map_mp mp' mp2') in - let sub = add_mp mp' mp2' sub in - (join s sub, register_alias mp' mp2 env) - with Not_found -> failwith "unkown aliased module") + let _= check_module env (MPdot(mp,lab)) msb in + Modops.add_module msb env | SFBmodtype mty -> - let kn = MPdot(mp, lab) in check_module_type env mty; - (join s mty.typ_alias, add_modtype kn mty env) - -and check_modexpr env mse = match mse with + add_modtype (MPdot(mp,lab)) mty env + +and check_modexpr env mse mp_mse = match mse with + | SEBident mp -> + let mb = lookup_module mp env in + (subst_and_strengthen mb mp_mse env).mod_type + | SEBfunctor (arg_id, mtb, body) -> + check_module_type env mtb ; + let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in + let sign = check_modexpr env' body mp_mse in + SEBfunctor (arg_id, mtb, sign) + | SEBapply (f,m,cst) -> + let sign = check_modexpr env f mp_mse in + let farg_id, farg_b, fbody_b = destr_functor env sign in + let mp = + try (path_of_mexpr m) + with Not_path -> error_application_to_not_path m + (* place for nondep_supertype *) in + let mtb = module_type_of_module env (Some mp) (lookup_module mp env) in + check_subtypes env mtb farg_b; + (subst_struct_expr (map_mbid farg_id mp) fbody_b) + | SEBwith(mte, with_decl) -> + let sign = check_modexpr env mte mp_mse in + let sign = check_with env sign with_decl mp_mse in + sign + | SEBstruct(msb) -> + let _ = List.fold_left (fun env (lab,mb) -> + check_structure_field env mp_mse lab mb) env msb in + SEBstruct(msb) + +and check_modtype env mse mp_mse= match mse with | SEBident mp -> - let mp = scrape_alias mp env in let mtb = lookup_modtype mp env in - mtb.typ_alias + mtb.typ_expr | SEBfunctor (arg_id, mtb, body) -> check_module_type env mtb; - let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in - let sub = check_modexpr env' body in - sub + let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in + let body = check_modtype env' body mp_mse in + SEBfunctor(arg_id,mtb,body) | SEBapply (f,m,cst) -> - let sub1 = check_modexpr env f in - let f'= eval_struct env f in - let farg_id, farg_b, fbody_b = destr_functor env f' in + let sign = check_modtype env f mp_mse in + let farg_id, farg_b, fbody_b = destr_functor env sign in let mp = - try scrape_alias (path_of_mexpr m) env + try (path_of_mexpr m) with Not_path -> error_application_to_not_path m - (* place for nondep_supertype *) in - let mtb = lookup_modtype mp env in - check_subtypes env mtb farg_b; - let sub2 = match eval_struct env m with - | SEBstruct (msid,sign) -> - join_alias - (subst_key (map_msid msid mp) mtb.typ_alias) - (map_msid msid mp) - | _ -> mtb.typ_alias in - let sub3 = join_alias sub1 (map_mbid farg_id mp) in - let sub4 = update_subst sub2 sub3 in - join sub3 sub4 + (* place for nondep_supertype *) in + let mtb = module_type_of_module env (Some mp) (lookup_module mp env) in + check_subtypes env mtb farg_b; + subst_struct_expr (map_mbid farg_id mp) fbody_b | SEBwith(mte, with_decl) -> - let sub1 = check_modexpr env mte in - let sub2 = check_with env mte with_decl in - join sub1 sub2 - | SEBstruct(msid,msb) -> - let mp = MPself msid in - let (sub,_) = - List.fold_left (fun env (lab,mb) -> - check_structure_field env mp lab mb) (empty_subst,env) msb in - sub - + let sign = check_modtype env mte mp_mse in + let sign = check_with env sign with_decl mp_mse in + sign + | SEBstruct(msb) -> + let _ = List.fold_left (fun env (lab,mb) -> + check_structure_field env mp_mse lab mb) env msb in + SEBstruct(msb) + (* -let rec add_struct_expr_constraints env = function + let rec add_struct_expr_constraints env = function | SEBident _ -> env - + | SEBfunctor (_,mtb,meb) -> - add_struct_expr_constraints - (add_modtype_constraints env mtb) meb + add_struct_expr_constraints + (add_modtype_constraints env mtb) meb | SEBstruct (_,structure_body) -> List.fold_left diff --git a/checker/modops.ml b/checker/modops.ml index a986e1898..3d07135d1 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -32,11 +32,10 @@ let error_not_match l _ = let error_no_such_label l = error ("No such label "^string_of_label l) -let error_no_such_label_sub l l1 l2 = - let l1 = string_of_msid l1 in - let l2 = string_of_msid l2 in - error (l1^" is not a subtype of "^l2^".\nThe field "^ - string_of_label l^" is missing (or invisible) in "^l1^".") +let error_no_such_label_sub l l1 = + let l1 = string_of_mp l1 in + error ("The field "^ + string_of_label l^" is missing in "^l1^".") let error_not_a_module_loc loc s = user_err_loc (loc,"",str ("\""^string_of_label s^"\" is not a module")) @@ -56,38 +55,6 @@ let error_signature_expected mtb = let error_application_to_not_path _ = error "Application to not path" - -let module_body_of_type mtb = - { mod_type = Some mtb.typ_expr; - mod_expr = None; - mod_constraints = Constraint.empty; - mod_alias = mtb.typ_alias; - mod_retroknowledge = []} - -let module_type_of_module mp mb = - {typ_expr = - (match mb.mod_type with - | Some expr -> expr - | None -> (match mb.mod_expr with - | Some expr -> expr - | None -> - anomaly "Modops: empty expr and type")); - typ_alias = mb.mod_alias; - typ_strength = mp - } - - - -let rec list_split_assoc k rev_before = function - | [] -> raise Not_found - | (k',b)::after when k=k' -> rev_before,b,after - | h::tail -> list_split_assoc k (h::rev_before) tail - -let path_of_seb = function - | SEBident mp -> mp - | _ -> anomaly "Modops: evaluation failed." - - let destr_functor env mtb = match mtb with | SEBfunctor (arg_id,arg_t,body_t) -> @@ -95,254 +62,157 @@ let destr_functor env mtb = | _ -> error_not_a_functor mtb -let rec check_modpath_equiv env mp1 mp2 = - if mp1=mp2 then () else - let mp1 = scrape_alias mp1 env in - let mp2 = scrape_alias mp2 env in - if mp1=mp2 then () - else - error_not_equal mp1 mp2 - - - -let strengthen_const env mp l cb = - match cb.const_opaque, cb.const_body with - | false, Some _ -> cb - | true, Some _ - | _, None -> - let const = Const (make_con mp empty_dirpath l) in - let const_subs = Some (Declarations.from_val const) in - {cb with - const_body = const_subs; - const_opaque = false - } - -let strengthen_mind env mp l mib = match mib.mind_equiv with - | Some _ -> mib - | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)} - +let is_functor = function + | SEBfunctor (arg_id,arg_t,body_t) -> true + | _ -> false -let rec eval_struct env = function - | SEBident mp -> - begin - let mp = scrape_alias mp env in - let mtb =lookup_modtype mp env in - match mtb.typ_expr,mtb.typ_strength with - mtb,None -> eval_struct env mtb - | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb) - end - | SEBapply (seb1,seb2,_) -> - let svb1 = eval_struct env seb1 in - let farg_id, farg_b, fbody_b = destr_functor env svb1 in - let mp = path_of_seb seb2 in - let mp = scrape_alias mp env in - let sub_alias = (lookup_modtype mp env).typ_alias in - let sub_alias = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> subst_key (map_msid msid mp) sub_alias - | _ -> sub_alias in - let sub_alias = update_subst_alias sub_alias - (map_mbid farg_id mp) in - eval_struct env (subst_struct_expr - (join sub_alias (map_mbid farg_id mp)) fbody_b) - | SEBwith (mtb,(With_definition_body _ as wdb)) -> - merge_with env mtb wdb empty_subst - | SEBwith (mtb, (With_module_body (_,mp,_,_) as wdb)) -> - let alias_in_mp = - (lookup_modtype mp env).typ_alias in - merge_with env mtb wdb alias_in_mp -(* | SEBfunctor(mbid,mtb,body) -> - let env = add_module (MPbound mbid) (module_body_of_type mtb) env in - SEBfunctor(mbid,mtb,eval_struct env body) *) - | mtb -> mtb - -and type_of_mb env mb = - match mb.mod_type,mb.mod_expr with - None,Some b -> eval_struct env b - | Some t, _ -> eval_struct env t - | _,_ -> anomaly - "Modops: empty type and empty expr" +let module_body_of_type mp mtb = + { mod_mp = mp; + mod_type = mtb.typ_expr; + mod_type_alg = mtb.typ_expr_alg; + mod_expr = None; + mod_constraints = mtb.typ_constraints; + mod_delta = mtb.typ_delta; + mod_retroknowledge = []} -and merge_with env mtb with_decl alias= - let msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) -> msid,sig_b - | _ -> error_signature_expected mtb - in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl - | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false - in - let l = label_of_id id in - try - let rev_before,spec,after = list_split_assoc l [] sig_b in - let before = List.rev rev_before in - let rec mp_rec = function - | [] -> MPself msid - | i::r -> MPdot(mp_rec r,label_of_id i) - in - let new_spec,subst = match with_decl with - | With_definition_body ([],_) - | With_module_body ([],_,_,_) -> assert false - | With_definition_body ([id],c) -> - SFBconst c,None - | With_module_body ([id], mp,typ_opt,cst) -> - let mp' = scrape_alias mp env in - SFBalias (mp,typ_opt,Some cst), - Some(join (map_mp (mp_rec [id]) mp') alias) - | With_definition_body (_::_,_) - | With_module_body (_::_,_,_,_) -> - let old = match spec with - SFBmodule msb -> msb - | _ -> error_not_a_module l - in - let new_with_decl,subst1 = - match with_decl with - With_definition_body (_,c) -> With_definition_body (idl,c),None - | With_module_body (idc,mp,t,cst) -> - With_module_body (idl,mp,t,cst), - Some(map_mp (mp_rec idc) mp) - in - let subst = Option.fold_right join subst1 alias in - let modtype = - merge_with env (type_of_mb env old) new_with_decl alias in - let msb = - { mod_expr = None; - mod_type = Some modtype; - mod_constraints = old.mod_constraints; - mod_alias = subst; - mod_retroknowledge = old.mod_retroknowledge} - in - (SFBmodule msb),Some subst - in - SEBstruct(msid, before@(l,new_spec):: - (Option.fold_right subst_structure subst after)) - with - Not_found -> error_no_such_label l +let check_modpath_equiv env mp1 mp2 = + if mp1=mp2 then () else + (* let mb1=lookup_module mp1 env in + let mb2=lookup_module mp2 env in + if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2) + then () + else*) error_not_equal mp1 mp2 -and add_signature mp sign env = +let rec add_signature mp sign resolver env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in - let con = make_con mp empty_dirpath l in + let con = constant_of_kn kn in + let mind = mind_of_kn kn in match elem with - | SFBconst cb -> Environ.add_constant con cb env - | SFBmind mib -> Environ.add_mind kn mib env - | SFBmodule mb -> - add_module (MPdot (mp,l)) mb env + | SFBconst cb -> + (* let con = constant_of_delta resolver con in*) + Environ.add_constant con cb env + | SFBmind mib -> + (* let mind = mind_of_delta resolver mind in*) + Environ.add_mind mind mib env + | SFBmodule mb -> add_module mb env (* adds components as well *) - | SFBalias (mp1,_,cst) -> - Environ.register_alias (MPdot(mp,l)) mp1 env - | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) - mtb env + | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env in List.fold_left add_one env sign -and add_module mp mb env = +and add_module mb env = + let mp = mb.mod_mp in let env = Environ.shallow_add_module mp mb env in - let env = - Environ.add_modtype mp (module_type_of_module (Some mp) mb) env - in - let mod_typ = type_of_mb env mb in - match mod_typ with - | SEBstruct (msid,sign) -> - add_signature mp (subst_signature_msid msid mp sign) env + match mb.mod_type with + | SEBstruct (sign) -> + add_signature mp sign mb.mod_delta env | SEBfunctor _ -> env | _ -> anomaly "Modops:the evaluation of the structure failed " - -and constants_of_specification env mp sign = - let aux (env,res) (l,elem) = - match elem with - | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res - | SFBmind _ -> env,res - | SFBmodule mb -> - let new_env = add_module (MPdot (mp,l)) mb env in - new_env,(constants_of_modtype env (MPdot (mp,l)) - (type_of_mb env mb)) @ res - | SFBalias (mp1,_,cst) -> - let new_env = register_alias (MPdot (mp,l)) mp1 env in - new_env,(constants_of_modtype env (MPdot (mp,l)) - (eval_struct env (SEBident mp1))) @ res - | SFBmodtype mtb -> - (* module type dans un module type. - Il faut au moins mettre mtb dans l'environnement (avec le bon - kn pour pouvoir continuer aller deplier les modules utilisant ce - mtb - ex: - Module Type T1. - Module Type T2. - .... - End T2. - ..... - Declare Module M : T2. - End T2 - si on ne rajoute pas T2 dans l'environement de typage - on va exploser au moment du Declare Module - *) - let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in - new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res - in - snd (List.fold_left aux (env,[]) sign) - -and constants_of_modtype env mp modtype = - match (eval_struct env modtype) with - SEBstruct (msid,sign) -> - constants_of_specification env mp - (subst_signature_msid msid mp sign) - | SEBfunctor _ -> [] - | _ -> anomaly "Modops:the evaluation of the structure failed " - -and strengthen_mtb env mp mtb = - let mtb1 = eval_struct env mtb in - match mtb1 with - | SEBfunctor _ -> mtb1 - | SEBstruct (msid,sign) -> - SEBstruct (msid,strengthen_sig env msid sign mp) - | _ -> anomaly "Modops:the evaluation of the structure failed " - -and strengthen_mod env mp mb = - let mod_typ = type_of_mb env mb in - { mod_expr = mb.mod_expr; - mod_type = Some (strengthen_mtb env mp mod_typ); - mod_constraints = mb.mod_constraints; - mod_alias = mb.mod_alias; - mod_retroknowledge = mb.mod_retroknowledge} - -and strengthen_sig env msid sign mp = match sign with - | [] -> [] - | (l,SFBconst cb) :: rest -> - let item' = l,SFBconst (strengthen_const env mp l cb) in - let rest' = strengthen_sig env msid rest mp in - item'::rest' - | (l,SFBmind mib) :: rest -> - let item' = l,SFBmind (strengthen_mind env mp l mib) in - let rest' = strengthen_sig env msid rest mp in - item'::rest' - | (l,SFBmodule mb) :: rest -> - let mp' = MPdot (mp,l) in - let item' = l,SFBmodule (strengthen_mod env mp' mb) in - let env' = add_module - (MPdot (MPself msid,l)) mb env in - let rest' = strengthen_sig env' msid rest mp in +let strengthen_const env mp_from l cb resolver = + match cb.const_opaque, cb.const_body with + | false, Some _ -> cb + | true, Some _ + | _, None -> + let con = make_con mp_from empty_dirpath l in + (* let con = constant_of_delta resolver con in*) + let const = Const con in + let const_subs = Some (Declarations.from_val const) in + {cb with + const_body = const_subs; + const_opaque = false; + } + + +let rec strengthen_mod env mp_from mp_to mb = + assert(mp_from = mb.mod_mp); +(* if mp_in_delta mb.mod_mp mb.mod_delta then + mb + else*) + match mb.mod_type with + | SEBstruct (sign) -> + let resolve_out,sign_out = + strengthen_sig env mp_from sign mp_to mb.mod_delta in + { mb with + mod_expr = Some (SEBident mp_to); + mod_type = SEBstruct(sign_out); + mod_type_alg = mb.mod_type_alg; + mod_constraints = mb.mod_constraints; + mod_delta = resolve_out(*add_mp_delta_resolver mp_from mp_to + (add_delta_resolver mb.mod_delta resolve_out)*); + mod_retroknowledge = mb.mod_retroknowledge} + | SEBfunctor _ -> mb + | _ -> anomaly "Modops:the evaluation of the structure failed " + +and strengthen_sig env mp_from sign mp_to resolver = + match sign with + | [] -> empty_delta_resolver,[] + | (l,SFBconst cb) :: rest -> + let item' = + l,SFBconst (strengthen_const env mp_from l cb resolver) in + let resolve_out,rest' = + strengthen_sig env mp_from rest mp_to resolver in + resolve_out,item'::rest' + | (_,SFBmind _ as item):: rest -> + let resolve_out,rest' = + strengthen_sig env mp_from rest mp_to resolver in + resolve_out,item::rest' + | (l,SFBmodule mb) :: rest -> + let mp_from' = MPdot (mp_from,l) in + let mp_to' = MPdot(mp_to,l) in + let mb_out = + strengthen_mod env mp_from' mp_to' mb in + let item' = l,SFBmodule (mb_out) in + let env' = add_module mb_out env in + let resolve_out,rest' = + strengthen_sig env' mp_from rest mp_to resolver in + resolve_out + (*add_delta_resolver resolve_out mb.mod_delta*), item':: rest' - | ((l,SFBalias (mp1,_,cst)) as item) :: rest -> - let env' = register_alias (MPdot(MPself msid,l)) mp1 env in - let rest' = strengthen_sig env' msid rest mp in - item::rest' - | (l,SFBmodtype mty as item) :: rest -> - let env' = add_modtype - (MPdot((MPself msid),l)) - mty - env - in - let rest' = strengthen_sig env' msid rest mp in - item::rest' - - -let strengthen env mtb mp = strengthen_mtb env mp mtb + | (l,SFBmodtype mty as item) :: rest -> + let env' = add_modtype + (MPdot(mp_from,l)) mty env + in + let resolve_out,rest' = + strengthen_sig env' mp_from rest mp_to resolver in + resolve_out,item::rest' + +let strengthen env mtb mp = +(* if mp_in_delta mtb.typ_mp mtb.typ_delta then + (* in this case mtb has already been strengthened*) + mtb + else*) + match mtb.typ_expr with + | SEBstruct (sign) -> + let resolve_out,sign_out = + strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in + {mtb with + typ_expr = SEBstruct(sign_out); + typ_delta = resolve_out(*add_delta_resolver mtb.typ_delta + (add_mp_delta_resolver mtb.typ_mp mp resolve_out)*)} + | SEBfunctor _ -> mtb + | _ -> anomaly "Modops:the evaluation of the structure failed " -let update_subst env mb mp = - match type_of_mb env mb with - | SEBstruct(msid,str) -> false, join_alias - (subst_key (map_msid msid mp) mb.mod_alias) - (map_msid msid mp) - | _ -> true, mb.mod_alias +let subst_and_strengthen mb mp env = + strengthen_mod env mb.mod_mp mp + (subst_module (map_mp mb.mod_mp mp) mb) + + +let module_type_of_module env mp mb = + match mp with + Some mp -> + strengthen env { + typ_mp = mp; + typ_expr = mb.mod_type; + typ_expr_alg = None; + typ_constraints = mb.mod_constraints; + typ_delta = mb.mod_delta} mp + + | None -> + {typ_mp = mb.mod_mp; + typ_expr = mb.mod_type; + typ_expr_alg = None; + typ_constraints = mb.mod_constraints; + typ_delta = mb.mod_delta} diff --git a/checker/modops.mli b/checker/modops.mli index d5c9f4de6..4476013c6 100644 --- a/checker/modops.mli +++ b/checker/modops.mli @@ -19,33 +19,25 @@ open Environ (* Various operations on modules and module types *) -(* make the environment entry out of type *) -val module_body_of_type : module_type_body -> module_body +(* make the envirconment entry out of type *) +val module_body_of_type : module_path -> module_type_body -> module_body -val module_type_of_module : module_path option -> module_body -> +val module_type_of_module : env -> module_path option -> module_body -> module_type_body val destr_functor : env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body -(* Evaluation functions *) -val eval_struct : env -> struct_expr_body -> struct_expr_body - -val type_of_mb : env -> module_body -> struct_expr_body - -(* [add_signature mp sign env] assumes that the substitution [msid] - $\mapsto$ [mp] has already been performed (or is not necessary, like - when [mp = MPself msid]) *) -val add_signature : module_path -> structure_body -> env -> env +val add_signature : module_path -> structure_body -> delta_resolver -> env -> env (* adds a module and its components, but not the constraints *) -val add_module : module_path -> module_body -> env -> env +val add_module : module_body -> env -> env val check_modpath_equiv : env -> module_path -> module_path -> unit -val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body +val strengthen : env -> module_type_body -> module_path -> module_type_body -val update_subst : env -> module_body -> module_path -> bool * substitution +val subst_and_strengthen : module_body -> module_path -> env -> module_body val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a @@ -57,7 +49,7 @@ val error_with_incorrect : label -> 'a val error_no_such_label : label -> 'a val error_no_such_label_sub : - label -> mod_self_id -> mod_self_id -> 'a + label -> module_path -> 'a val error_signature_expected : struct_expr_body -> 'a diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index b0d683ff3..da0e63c23 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -30,9 +30,8 @@ let set_engagement c = (* full_add_module adds module with universes and constraints *) let full_add_module dp mb digest = let env = !genv in - let mp = MPfile dp in let env = add_constraints mb.mod_constraints env in - let env = Modops.add_module mp mb env in + let env = Modops.add_module mb env in genv := add_digest env dp digest (* Check that the engagement expected by a library matches the initial one *) @@ -66,16 +65,16 @@ let check_imports f caller env needed = (* Remove the body of opaque constants in modules *) -(* also remove mod_expr ? *) +(* also remove mod_expr ? Good idea!*) let rec lighten_module mb = { mb with mod_expr = Option.map lighten_modexpr mb.mod_expr; - mod_type = Option.map lighten_modexpr mb.mod_type } + mod_type = lighten_modexpr mb.mod_type } and lighten_struct struc = let lighten_body (l,body) = (l,match body with | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None} - | (SFBconst _ | SFBmind _ | SFBalias _) as x -> x + | (SFBconst _ | SFBmind _ ) as x -> x | SFBmodule m -> SFBmodule (lighten_module m) | SFBmodtype m -> SFBmodtype ({m with @@ -90,8 +89,8 @@ and lighten_modexpr = function typ_expr = lighten_modexpr mty.typ_expr}), lighten_modexpr mexpr) | SEBident mp as x -> x - | SEBstruct (msid, struc) -> - SEBstruct (msid, lighten_struct struc) + | SEBstruct ( struc) -> + SEBstruct ( lighten_struct struc) | SEBapply (mexpr,marg,u) -> SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u) | SEBwith (seb,wdcl) -> @@ -125,7 +124,7 @@ let import file (dp,mb,depends,engmt as vo) digest = let env = !genv in check_imports msg_warning dp env depends; check_engagement env engmt; - check_module (add_constraints mb.mod_constraints env) mb; + check_module (add_constraints mb.mod_constraints env) mb.mod_mp mb; stamp_library file digest; (* We drop proofs once checked *) (* let mb = lighten_module mb in*) diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 88989b32e..ec1c908a6 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -32,7 +32,6 @@ type namedobject = | IndConstr of constructor * mutual_inductive_body | Module of module_body | Modtype of module_type_body - | Alias of module_path * struct_expr_body option (* adds above information about one mutual inductive: all types and constructors *) @@ -60,13 +59,13 @@ let make_label_map mp list = match e with | SFBconst cb -> add_map (Constant cb) | SFBmind mib -> - add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map + add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map | SFBmodule mb -> add_map (Module mb) | SFBmodtype mtb -> add_map (Modtype mtb) - | SFBalias (mp,typ_opt,cst) -> add_map (Alias (mp,typ_opt)) in List.fold_right add_one list Labmap.empty + let check_conv_error error f env a1 a2 = try f env a1 a2 @@ -74,8 +73,8 @@ let check_conv_error error f env a1 a2 = NotConvertible -> error () (* for now we do not allow reorderings *) -let check_inductive env msid1 l info1 mib2 spec2 = - let kn = make_kn (MPself msid1) empty_dirpath l in +let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= + let kn = make_mind mp1 empty_dirpath l in let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in let mib1 = @@ -83,6 +82,7 @@ let check_inductive env msid1 l info1 mib2 spec2 = | IndType ((_,0), mib) -> mib | _ -> error () in + let mib2 = subst_mind subst2 mib2 in let check_inductive_type env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of @@ -155,7 +155,7 @@ let check_inductive env msid1 l info1 mib2 spec2 = (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams); - begin + (*begin match mib2.mind_equiv with | None -> () | Some kn2' -> @@ -165,7 +165,7 @@ let check_inductive env msid1 l info1 mib2 spec2 = | Some kn1' -> scrape_mind env kn1' in if kn1 <> kn2 then error () - end; + end;*) (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record); if mib1.mind_record then begin @@ -187,7 +187,7 @@ let check_inductive env msid1 l info1 mib2 spec2 = let _ = array_map2_i check_cons_types mib1.mind_packets mib2.mind_packets in () -let check_constant env msid1 l info1 cb2 spec2 = +let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in let check_type env t1 t2 = @@ -236,30 +236,31 @@ let check_constant env msid1 l info1 cb2 spec2 = (t1,t2) in check_conv conv_leq env t1 t2 in - - match info1 with - | Constant cb1 -> - assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; - (*Start by checking types*) - let typ1 = Typeops.type_of_constant_type env cb1.const_type in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in - check_type env typ1 typ2; - let con = make_con (MPself msid1) empty_dirpath l in - (match cb2 with - | {const_body=Some lc2;const_opaque=false} -> - let c2 = force_constr lc2 in - let c1 = match cb1.const_body with - | Some lc1 -> force_constr lc1 - | None -> Const con - in - check_conv conv env c1 c2 - | _ -> ()) - | IndType ((kn,i),mind1) -> - ignore (Util.error ( - "The kernel does not recognize yet that a parameter can be " ^ - "instantiated by an inductive type. Hint: you can rename the " ^ - "inductive type and give a definition to map the old name to the new " ^ - "name.")); + match info1 with + | Constant cb1 -> + assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; + (*Start by checking types*) + let cb1 = subst_const_body subst1 cb1 in + let cb2 = subst_const_body subst2 cb2 in + let typ1 = Typeops.type_of_constant_type env cb1.const_type in + let typ2 = Typeops.type_of_constant_type env cb2.const_type in + check_type env typ1 typ2; + let con = make_con mp1 empty_dirpath l in + (match cb2 with + | {const_body=Some lc2;const_opaque=false} -> + let c2 = force_constr lc2 in + let c1 = match cb1.const_body with + | Some lc1 -> force_constr lc1 + | None -> Const con + in + check_conv conv env c1 c2 + | _ -> ()) + | IndType ((kn,i),mind1) -> + ignore (Util.error ( + "The kernel does not recognize yet that a parameter can be " ^ + "instantiated by an inductive type. Hint: you can rename the " ^ + "inductive type and give a definition to map the old name to the new " ^ + "name.")); assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; if cb2.const_body <> None then error () ; let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in @@ -278,57 +279,31 @@ let check_constant env msid1 l info1 cb2 spec2 = check_conv conv env ty1 ty2 | _ -> error () -let rec check_modules env msid1 l msb1 msb2 = - let mp = (MPdot(MPself msid1,l)) in - let mty1 = module_type_of_module (Some mp) msb1 in - let mty2 = module_type_of_module None msb2 in - check_modtypes env mty1 mty2 false +let rec check_modules env msb1 msb2 subst1 subst2 = + let mty1 = module_type_of_module env None msb1 in + let mty2 = module_type_of_module env None msb2 in + check_modtypes env mty1 mty2 subst1 subst2 false; + - -and check_signatures env (msid1,sig1) alias (msid2,sig2') = - let mp1 = MPself msid1 in - let env = add_signature mp1 sig1 env in - let alias = update_subst_alias alias (map_msid msid2 mp1) in - let sig2 = subst_structure alias sig2' in - let sig2 = subst_signature_msid msid2 mp1 sig2 in +and check_signatures env mp1 sig1 sig2 subst1 subst2 = let map1 = make_label_map mp1 sig1 in - let check_one_body (l,spec2) = + let check_one_body (l,spec2) = let info1 = try Labmap.find l map1 with - Not_found -> error_no_such_label_sub l msid1 msid2 + Not_found -> error_no_such_label_sub l mp1 in match spec2 with | SFBconst cb2 -> - check_constant env msid1 l info1 cb2 spec2 + check_constant env mp1 l info1 cb2 spec2 subst1 subst2 | SFBmind mib2 -> - check_inductive env msid1 l info1 mib2 spec2 + check_inductive env mp1 l info1 mib2 spec2 subst1 subst2 | SFBmodule msb2 -> begin match info1 with - | Module msb -> check_modules env msid1 l msb msb2 - | Alias (mp,typ_opt) ->let msb = - {mod_expr = Some (SEBident mp); - mod_type = typ_opt; - mod_constraints = Constraint.empty; - mod_alias = (lookup_modtype mp env).typ_alias; - mod_retroknowledge = []} in - check_modules env msid1 l msb msb2 - | _ -> error_not_match l spec2 - end - | SFBalias (mp,typ_opt,_) -> - begin - match info1 with - | Alias (mp1,_) -> check_modpath_equiv env mp mp1 - | Module msb -> - let msb1 = - {mod_expr = Some (SEBident mp); - mod_type = typ_opt; - mod_constraints = Constraint.empty; - mod_alias = (lookup_modtype mp env).typ_alias; - mod_retroknowledge = []} in - check_modules env msid1 l msb msb1 + | Module msb -> check_modules env msb msb2 + subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> @@ -337,52 +312,61 @@ and check_signatures env (msid1,sig1) alias (msid2,sig2') = | Modtype mtb -> mtb | _ -> error_not_match l spec2 in - check_modtypes env mtb1 mtb2 true + let env = add_module (module_body_of_type mtb2.typ_mp mtb2) + (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in + check_modtypes env mtb1 mtb2 subst1 subst2 true in List.iter check_one_body sig2 -and check_modtypes env mtb1 mtb2 equiv = - if mtb1==mtb2 then () else (* just in case :) *) - let mtb1',mtb2'= - (match mtb1.typ_strength with - None -> eval_struct env mtb1.typ_expr, - eval_struct env mtb2.typ_expr - | Some mp -> strengthen env mtb1.typ_expr mp, - eval_struct env mtb2.typ_expr) in - let rec check_structure env str1 str2 equiv = - match str1, str2 with - | SEBstruct (msid1,list1), - SEBstruct (msid2,list2) -> - check_signatures env - (msid1,list1) mtb1.typ_alias (msid2,list2); - if equiv then - check_signatures env - (msid2,list2) mtb2.typ_alias (msid1,list1) +and check_modtypes env mtb1 mtb2 subst1 subst2 equiv = + if mtb1==mtb2 then () else + let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in + let rec check_structure env str1 str2 equiv subst1 subst2 = + match str1,str2 with + | SEBstruct (list1), + SEBstruct (list2) -> + check_signatures env + mtb1.typ_mp list1 list2 subst1 subst2; + if equiv then + check_signatures env + mtb2.typ_mp list2 list1 subst1 subst2 + else + () | SEBfunctor (arg_id1,arg_t1,body_t1), SEBfunctor (arg_id2,arg_t2,body_t2) -> - check_modtypes env arg_t2 arg_t1 equiv; + check_modtypes env + arg_t2 arg_t1 + (map_mp arg_t1.typ_mp arg_t2.typ_mp) subst2 + equiv ; (* contravariant *) - let env = - add_module (MPbound arg_id2) (module_body_of_type arg_t2) env + let env = add_module + (module_body_of_type (MPbound arg_id2) arg_t2) env in - let body_t1' = - (* since we are just checking well-typedness we do not need - to expand any constant. Hence the identity resolver. *) - subst_struct_expr - (map_mbid arg_id1 (MPbound arg_id2)) - body_t1 + let env = match body_t1 with + SEBstruct str -> + add_module {mod_mp = mtb1.typ_mp; + mod_expr = None; + mod_type = body_t1; + mod_type_alg= None; + mod_constraints=mtb1.typ_constraints; + mod_retroknowledge = []; + mod_delta = mtb1.typ_delta} env + | _ -> env in - check_structure env (eval_struct env body_t1') - (eval_struct env body_t2) equiv + check_structure env body_t1 body_t2 equiv + (join (map_mbid arg_id1 (MPbound arg_id2)) subst1) + subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 in if mtb1'== mtb2' then () - else check_structure env mtb1' mtb2' equiv + else check_structure env mtb1' mtb2' equiv subst1 subst2 let check_subtypes env sup super = (*if sup<>super then*) - check_modtypes env sup super false + check_modtypes env (strengthen env sup sup.typ_mp) super empty_subst + (map_mp super.typ_mp sup.typ_mp) false let check_equal env sup super = (*if sup<>super then*) - check_modtypes env sup super true + check_modtypes env sup super empty_subst + (map_mp super.typ_mp sup.typ_mp) true diff --git a/checker/term.ml b/checker/term.ml index 92d898b31..658eac4f0 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -489,7 +489,7 @@ let compare_constr f t1 t2 = f h1 h2 & List.for_all2 f l1 l2 else false | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 - | Const c1, Const c2 -> c1 = c2 + | Const c1, Const c2 -> eq_constant c1 c2 | Ind c1, Ind c2 -> c1 = c2 | Construct c1, Construct c2 -> c1 = c2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> diff --git a/checker/typeops.ml b/checker/typeops.ml index 3a4f2f825..e5cf6a6d6 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -228,7 +228,7 @@ let judge_of_inductive_knowing_parameters env ind (paramstyp:constr array) = let (mib,mip) = try lookup_mind_specif env ind with Not_found -> - failwith ("Cannot find inductive: "^string_of_kn (fst ind)) in + failwith ("Cannot find inductive: "^string_of_mind (fst ind)) in check_args env c mib.mind_hyps; type_of_inductive_knowing_parameters env mip paramstyp @@ -244,7 +244,7 @@ let judge_of_constructor env c = let mib = try lookup_mind kn env with Not_found -> - failwith ("Cannot find inductive: "^string_of_kn (fst (fst c))) in + failwith ("Cannot find inductive: "^string_of_mind (fst (fst c))) in check_args env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in type_of_constructor c specif @@ -11,6 +11,7 @@ install_printer Top_printers.ppdir install_printer Top_printers.ppmp install_printer Top_printers.ppkn install_printer Top_printers.ppcon +install_printer Top_printers.ppmind install_printer Top_printers.ppsp install_printer Top_printers.ppqualid install_printer Top_printers.ppclindex @@ -39,5 +40,5 @@ install_printer Top_printers.pptac install_printer Top_printers.ppobj install_printer Top_printers.pploc install_printer Top_printers.prsubst - - +install_printer Top_printers.prdelta +install_printer Top_printers.print_pure_constr diff --git a/dev/printers.mllib b/dev/printers.mllib index 107b2904a..b5a54a189 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -54,9 +54,9 @@ Mod_typing Safe_typing Summary -Global Nameops Libnames +Global Nametab Libobject Lib diff --git a/dev/top_printers.ml b/dev/top_printers.ml index d5ebde7cb..310fb1188 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -28,6 +28,7 @@ open Cerrors open Evd open Goptions open Genarg +open Mod_subst let _ = Constrextern.print_evar_arguments := true @@ -44,8 +45,9 @@ let ppmsid msid = pp (str (debug_string_of_msid msid)) let ppmbid mbid = pp (str (debug_string_of_mbid mbid)) let ppdir dir = pp (pr_dirpath dir) let ppmp mp = pp(str (string_of_mp mp)) -let ppcon con = pp(pr_con con) +let ppcon con = pp(debug_pr_con con) let ppkn kn = pp(pr_kn kn) +let ppmind kn = pp(debug_pr_mind kn) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) let ppclindex cl = pp(Classops.pr_cl_index cl) @@ -72,10 +74,10 @@ let ppidset l = pp (prset pr_id (Idset.elements l)) let pP s = pp (hov 0 s) let safe_pr_global = function - | ConstRef kn -> pp (str "CONSTREF(" ++ pr_con kn ++ str ")") - | IndRef (kn,i) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ + | ConstRef kn -> pp (str "CONSTREF(" ++ debug_pr_con kn ++ str ")") + | IndRef (kn,i) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++ int i ++ str ")") - | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ + | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ debug_pr_mind kn ++ str "," ++ int i ++ str "," ++ int j ++ str ")") | VarRef id -> pp (str "VARREF(" ++ pr_id id ++ str ")") @@ -92,6 +94,7 @@ let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t) let ppj j = pp (genppj pr_ljudge j) let prsubst s = pp (Mod_subst.debug_pr_subst s) +let prdelta s = pp (Mod_subst.debug_pr_delta s) let pp_idpred s = pp (pr_idpred s) let pp_cpred s = pp (pr_cpred s) @@ -159,9 +162,9 @@ let constr_display csr = | Evar (e,l) -> "Evar("^(string_of_int e)^","^(array_display l)^")" | Const c -> "Const("^(string_of_con c)^")" | Ind (sp,i) -> - "MutInd("^(string_of_kn sp)^","^(string_of_int i)^")" + "MutInd("^(string_of_mind sp)^","^(string_of_int i)^")" | Construct ((sp,i),j) -> - "MutConstruct(("^(string_of_kn sp)^","^(string_of_int i)^")," + "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^")," ^(string_of_int j)^")" | Case (ci,p,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," @@ -309,7 +312,7 @@ let print_pure_constr csr = | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) - print_string (string_of_kn sp) + print_string (debug_string_of_mind sp) and sp_con_display sp = (* let dir,l = decode_kn sp in let ls = @@ -318,7 +321,7 @@ let print_pure_constr csr = | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) - print_string (string_of_con sp) + print_string (debug_string_of_con sp) in try @@ -442,11 +445,11 @@ let raw_string_of_ref loc = function let (mp,dir,id) = repr_con cst in encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id) | IndRef (kn,i) -> - let (mp,dir,id) = repr_kn kn in + let (mp,dir,id) = repr_mind kn in encode_path loc "IND" (Some (mp,dir)) [id_of_label id] (id_of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> - let (mp,dir,id) = repr_kn kn in + let (mp,dir,id) = repr_mind kn in encode_path loc "CSTR" (Some (mp,dir)) [id_of_label id;id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) @@ -456,13 +459,13 @@ let raw_string_of_ref loc = function let short_string_of_ref loc = function | VarRef id -> Ident (loc,id) | ConstRef cst -> Ident (loc,id_of_label (pi3 (repr_con cst))) - | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_kn kn))) + | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn))) | IndRef (kn,i) -> - encode_path loc "IND" None [id_of_label (pi3 (repr_kn kn))] + encode_path loc "IND" None [id_of_label (pi3 (repr_mind kn))] (id_of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> encode_path loc "CSTR" None - [id_of_label (pi3 (repr_kn kn));id_of_string ("_"^string_of_int i)] + [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) let _ = Constrextern.set_debug_global_reference_printer diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 266bd1043..59545d8aa 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -10,7 +10,7 @@ let ppripos (ri,pos) = | Reloc_annot a -> let sp,i = a.ci.ci_ind in print_string - ("annot : MutInd("^(string_of_kn sp)^","^(string_of_int i)^")\n") + ("annot : MutInd("^(string_of_mind sp)^","^(string_of_int i)^")\n") | Reloc_const _ -> print_string "structured constant\n" | Reloc_getglobal kn -> @@ -62,7 +62,7 @@ and ppatom a = | Aid idk -> print_idkey idk | Aiddef(idk,_) -> print_string "&";print_idkey idk | Aind(sp,i) -> print_string "Ind("; - print_string (string_of_kn sp); + print_string (string_of_mind sp); print_string ","; print_int i; print_string ")" diff --git a/interp/coqlib.ml b/interp/coqlib.ml index b44cabe8b..90432a4a4 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -66,14 +66,20 @@ let gen_constant_in_modules locstr dirs s = let check_required_library d = let d' = List.map id_of_string d in let dir = make_dirpath (List.rev d') in + let mp = (fst(Lib.current_prefix())) in + let current_dir = match mp with + | MPfile dp -> (dir=dp) + | _ -> false + in if not (Library.library_is_loaded dir) then + if not current_dir then (* Loading silently ... let m, prefix = list_sep_last d' in read_library (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m) *) (* or failing ...*) - error ("Library "^(string_of_dirpath dir)^" has to be required first.") + error ("Library "^(string_of_dirpath dir)^" has to be required first.") (************************************************************************) (* Specific Coq objects *) @@ -123,7 +129,7 @@ let jmeq_module_name = ["Coq";"Logic";"JMeq"] let jmeq_module = make_dir jmeq_module_name (* TODO: temporary hack *) -let make_kn dir id = Libnames.encode_kn dir id +let make_kn dir id = Libnames.encode_mind dir id let make_con dir id = Libnames.encode_con dir id (** Identity *) diff --git a/interp/notation.ml b/interp/notation.ml index 342cb6c9c..8f9f0959d 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -109,7 +109,7 @@ let open_scope i (_,(local,op,sc)) = let cache_scope o = open_scope 1 o -let subst_scope (_,subst,sc) = sc +let subst_scope (subst,sc) = sc open Libobject @@ -180,19 +180,29 @@ type key = let notations_key_table = ref Gmapl.empty let prim_token_key_table = Hashtbl.create 7 + +let make_gr = function + | ConstRef con -> + ConstRef(constant_of_kn(canonical_con con)) + | IndRef (kn,i) -> + IndRef(mind_of_kn(canonical_mind kn),i) + | ConstructRef ((kn,i),j )-> + ConstructRef((mind_of_kn(canonical_mind kn),i),j) + | VarRef id -> VarRef id + let rawconstr_key = function - | RApp (_,RRef (_,ref),_) -> RefKey ref - | RRef (_,ref) -> RefKey ref + | RApp (_,RRef (_,ref),_) -> RefKey (make_gr ref) + | RRef (_,ref) -> RefKey (make_gr ref) | _ -> Oth let cases_pattern_key = function - | PatCstr (_,ref,_,_) -> RefKey (ConstructRef ref) + | PatCstr (_,ref,_,_) -> RefKey (make_gr (ConstructRef ref)) | _ -> Oth let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *) - | AApp (ARef ref,args) -> RefKey ref, Some (List.length args) - | AList (_,_,AApp (ARef ref,args),_,_) -> RefKey ref, Some (List.length args) - | ARef ref -> RefKey ref, None + | AApp (ARef ref,args) -> RefKey(make_gr ref), Some (List.length args) + | AList (_,_,AApp (ARef ref,args),_,_) -> RefKey (make_gr ref), Some (List.length args) + | ARef ref -> RefKey(make_gr ref), None | _ -> Oth, None (**********************************************************************) @@ -458,7 +468,7 @@ let load_arguments_scope _ (_,(_,r,scl)) = let cache_arguments_scope o = load_arguments_scope 1 o -let subst_arguments_scope (_,subst,(req,r,scl)) = +let subst_arguments_scope (subst,(req,r,scl)) = (ArgsScopeNoDischarge,fst (subst_global subst r),scl) let discharge_arguments_scope (_,(req,r,l)) = diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 939fe01aa..1330a3689 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -51,7 +51,7 @@ let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = let cache_syntax_constant d = load_syntax_constant 1 d -let subst_syntax_constant ((sp,kn),subst,(local,pat,onlyparse)) = +let subst_syntax_constant (subst,(local,pat,onlyparse)) = (local,subst_interpretation subst pat,onlyparse) let classify_syntax_constant (local,_,_ as o) = diff --git a/interp/topconstr.ml b/interp/topconstr.ml index bea0eae31..ec1b20a12 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -143,7 +143,7 @@ let has_ldots = (function RApp (_,RVar(_,v),_) when v = ldots_var -> true | _ -> false) let compare_rawconstr f t1 t2 = match t1,t2 with - | RRef (_,r1), RRef (_,r2) -> r1 = r2 + | RRef (_,r1), RRef (_,r2) -> eq_gr r1 r2 | RVar (_,v1), RVar (_,v2) -> v1 = v2 | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & List.for_all2 f l1 l2 | RLambda (_,na1,bk1,ty1,c1), RLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> @@ -281,7 +281,7 @@ let rec subst_pat subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_kn subst kn + let kn' = subst_ind subst kn and cpl' = list_smartmap (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -331,7 +331,7 @@ let rec subst_aconstr subst bound raw = (fun (a,(n,signopt) as x) -> let a' = subst_aconstr subst bound a in let signopt' = Option.map (fun ((indkn,i),n,nal as z) -> - let indkn' = subst_kn subst indkn in + let indkn' = subst_ind subst indkn in if indkn == indkn' then z else ((indkn',i),n,nal)) signopt in if a' == a && signopt' == signopt then x else (a',(n,signopt'))) rl @@ -485,7 +485,7 @@ let adjust_application_n n loc f l = let rec match_ alp metas sigma a1 a2 = match (a1,a2) with | r1, AVar id2 when List.mem id2 metas -> bind_env alp sigma id2 r1 | RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma - | RRef (_,r1), ARef r2 when r1 = r2 -> sigma + | RRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma | RPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma | RApp (loc,f1,l1), AApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index a7e8b0b26..e7859962e 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -723,7 +723,10 @@ let compile_constant_body env body opaque boxed = BCdefined(true, to_patch) else match kind_of_term body with - | Const kn' -> BCallias (get_allias env kn') + | Const kn' -> + (* we use the canonical name of the constant*) + let con= constant_of_kn (canonical_con kn') in + BCallias (get_allias env con) | _ -> let res = compile env body in let to_patch = to_memory res in diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 89264e88b..4a9c7da2b 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -304,13 +304,13 @@ let rec subst_strcst s sc = match sc with | Const_sorts _ | Const_b0 _ -> sc | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) - | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_kn s kn, i)) + | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i)) let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in - let ci = {a.ci with ci_ind = (subst_kn s kn,i)} in + let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos) diff --git a/kernel/closure.ml b/kernel/closure.ml index bce564397..93788ed42 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -196,6 +196,8 @@ let unfold_red kn = type table_key = id_key +let eq_table_key = Names.eq_id_key + type 'a infos = { i_flags : reds; i_repr : 'a infos -> constr -> 'a; @@ -250,18 +252,6 @@ let defined_rels flags env = (rel_context env) ~init:(0,[]) (* else (0,[])*) -let rec mind_equiv env (kn1,i1) (kn2,i2) = - let rec equiv kn1 kn2 = - kn1 = kn2 || - match (lookup_mind kn1 env).mind_equiv with - Some kn1' -> equiv kn2 kn1' - | None -> match (lookup_mind kn2 env).mind_equiv with - Some kn2' -> equiv kn2' kn1 - | None -> false in - i1 = i2 && equiv kn1 kn2 - -let mind_equiv_infos info = mind_equiv info.i_env - let create mk_cl flgs env evars = { i_flags = flgs; i_repr = mk_cl; diff --git a/kernel/closure.mli b/kernel/closure.mli index b6ff1fa15..5cb6fc97c 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -179,9 +179,7 @@ val whd_stack : (* [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> table_key -> fconstr option -(* [mind_equiv] checks whether two inductive types are intentionally equal *) -val mind_equiv : env -> inductive -> inductive -> bool -val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool +val eq_table_key : table_key -> table_key -> bool (************************************************************************) (*i This is for lazy debug *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index e42a732d3..c971ed299 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -19,15 +19,15 @@ open Reduction (*s Cooking the constants. *) -type work_list = identifier array Cmap.t * identifier array KNmap.t +type work_list = identifier array Cmap.t * identifier array Mindmap.t let pop_dirpath p = match repr_dirpath p with | [] -> anomaly "dirpath_prefix: empty dirpath" | _::l -> make_dirpath l -let pop_kn kn = - let (mp,dir,l) = Names.repr_kn kn in - Names.make_kn mp (pop_dirpath dir) l +let pop_mind kn = + let (mp,dir,l) = Names.repr_mind kn in + Names.make_mind mp (pop_dirpath dir) l let pop_con con = let (mp,dir,l) = Names.repr_con con in @@ -48,9 +48,9 @@ let share r (cstl,knl) = let f,l = match r with | IndRef (kn,i) -> - mkInd (pop_kn kn,i), KNmap.find kn knl + mkInd (pop_mind kn,i), Mindmap.find kn knl | ConstructRef ((kn,i),j) -> - mkConstruct ((pop_kn kn,i),j), KNmap.find kn knl + mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl | ConstRef cst -> mkConst (pop_con cst), Cmap.find cst cstl in let c = mkApp (f, Array.map mkVar l) in @@ -69,7 +69,7 @@ let update_case_info ci modlist = with Not_found -> ci -let empty_modlist = (Cmap.empty, KNmap.empty) +let empty_modlist = (Cmap.empty, Mindmap.empty) let expmod_constr modlist c = let rec substrec c = diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 23b1f2534..db35031d9 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -16,7 +16,7 @@ open Univ (*s Cooking the constants. *) -type work_list = identifier array Cmap.t * identifier array KNmap.t +type work_list = identifier array Cmap.t * identifier array Mindmap.t type recipe = { d_from : constant_body; diff --git a/kernel/declarations.ml b/kernel/declarations.ml index c48c01d78..515009798 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -69,7 +69,7 @@ type recarg = let subst_recarg sub r = match r with | Norec | Mrec _ -> r - | Imbr (kn,i) -> let kn' = subst_kn sub kn in + | Imbr (kn,i) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) type wf_paths = recarg Rtree.t @@ -190,25 +190,25 @@ type mutual_inductive_body = { (* Universes constraints enforced by the inductive declaration *) mind_constraints : constraints; - (* Source of the inductive block when aliased in a module *) - mind_equiv : kernel_name option } -let subst_arity sub = function -| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) -| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) - +let subst_arity sub arity = + if sub = empty_subst then arity + else match arity with + | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) + | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) + (* TODO: should be changed to non-coping after Term.subst_mps *) let subst_const_body sub cb = { - const_hyps = (assert (cb.const_hyps=[]); []); - const_body = Option.map (subst_constr_subst sub) cb.const_body; - const_type = subst_arity sub cb.const_type; - const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; - (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*) - const_constraints = cb.const_constraints; - const_opaque = cb.const_opaque; - const_inline = cb.const_inline} - + const_hyps = (assert (cb.const_hyps=[]); []); + const_body = Option.map (subst_constr_subst sub) cb.const_body; + const_type = subst_arity sub cb.const_type; + const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; + (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*) + const_constraints = cb.const_constraints; + const_opaque = cb.const_opaque; + const_inline = cb.const_inline} + let subst_arity sub = function | Monomorphic s -> Monomorphic { @@ -244,8 +244,7 @@ let subst_mind sub mib = mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; - mind_constraints = mib.mind_constraints ; - mind_equiv = Option.map (subst_kn sub) mib.mind_equiv } + mind_constraints = mib.mind_constraints } (*s Modules: signature component specifications, module types, and @@ -255,8 +254,6 @@ type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option - * constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -264,24 +261,26 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBstruct of mod_self_id * structure_body - | SEBapply of struct_expr_body * struct_expr_body - * constraints + | SEBapply of struct_expr_body * struct_expr_body * constraints + | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = With_module_body of identifier list * module_path - * struct_expr_body option * constraints | With_definition_body of identifier list * constant_body and module_body = - { mod_expr : struct_expr_body option; - mod_type : struct_expr_body option; + { mod_mp : module_path; + mod_expr : struct_expr_body option; + mod_type : struct_expr_body; + mod_type_alg : struct_expr_body option; mod_constraints : constraints; - mod_alias : substitution; + mod_delta : delta_resolver; mod_retroknowledge : Retroknowledge.action list} and module_type_body = - { typ_expr : struct_expr_body; - typ_strength : module_path option; - typ_alias : substitution} + { typ_mp : module_path; + typ_expr : struct_expr_body; + typ_expr_alg : struct_expr_body option ; + typ_constraints : constraints; + typ_delta :delta_resolver} diff --git a/kernel/declarations.mli b/kernel/declarations.mli index c7e27db6b..adf1d14e2 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -171,8 +171,6 @@ type mutual_inductive_body = { (* Universes constraints enforced by the inductive declaration *) mind_constraints : constraints; - (* Source of the inductive block when aliased in a module *) - mind_equiv : kernel_name option } val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body @@ -185,8 +183,6 @@ type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option - * constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list @@ -194,24 +190,38 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBstruct of mod_self_id * structure_body - | SEBapply of struct_expr_body * struct_expr_body - * constraints + | SEBapply of struct_expr_body * struct_expr_body * constraints + | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = With_module_body of identifier list * module_path - * struct_expr_body option * constraints | With_definition_body of identifier list * constant_body and module_body = - { mod_expr : struct_expr_body option; - mod_type : struct_expr_body option; + { (*absolute path of the module*) + mod_mp : module_path; + (* Implementation *) + mod_expr : struct_expr_body option; + (* Signature *) + mod_type : struct_expr_body; + (* algebraic structure expression is kept + if it's relevant for extraction *) + mod_type_alg : struct_expr_body option; + (* set of all constraint in the module *) mod_constraints : constraints; - mod_alias : substitution; + (* quotiented set of equivalent constant and inductive name *) + mod_delta : delta_resolver; mod_retroknowledge : Retroknowledge.action list} - + and module_type_body = - { typ_expr : struct_expr_body; - typ_strength : module_path option; - typ_alias : substitution} + { + (*Path of the module type*) + typ_mp : module_path; + typ_expr : struct_expr_body; + (* algebraic structure expression is kept + if it's relevant for extraction *) + typ_expr_alg : struct_expr_body option ; + typ_constraints : constraints; + (* quotiented set of equivalent constant and inductive name *) + typ_delta :delta_resolver} diff --git a/kernel/entries.ml b/kernel/entries.ml index 26e9a6250..938d1c60a 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -62,7 +62,8 @@ type definition_entry = { const_entry_opaque : bool; const_entry_boxed : bool} -type parameter_entry = types*bool +(* type and the inlining flag *) +type parameter_entry = types * bool type constant_entry = | DefinitionEntry of definition_entry @@ -70,7 +71,14 @@ type constant_entry = (*s Modules *) -type module_struct_entry = + +type specification_entry = + SPEconst of constant_entry + | SPEmind of mutual_inductive_entry + | SPEmodule of module_entry + | SPEmodtype of module_struct_entry + +and module_struct_entry = MSEident of module_path | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry | MSEwith of module_struct_entry * with_declaration diff --git a/kernel/entries.mli b/kernel/entries.mli index 291ff0d45..20fbbb8e7 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -61,7 +61,7 @@ type definition_entry = { const_entry_opaque : bool; const_entry_boxed : bool } -type parameter_entry = types*bool (*inline flag*) +type parameter_entry = types * bool (*inline flag*) type constant_entry = | DefinitionEntry of definition_entry @@ -69,7 +69,14 @@ type constant_entry = (*s Modules *) -type module_struct_entry = + +type specification_entry = + SPEconst of constant_entry + | SPEmind of mutual_inductive_entry + | SPEmodule of module_entry + | SPEmodtype of module_struct_entry + +and module_struct_entry = MSEident of module_path | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry | MSEwith of module_struct_entry * with_declaration diff --git a/kernel/environ.ml b/kernel/environ.ml index fb51660b3..a233d0be1 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -141,7 +141,7 @@ let lookup_constant = lookup_constant let add_constant kn cs env = let new_constants = - Cmap.add kn (cs,ref None) env.env_globals.env_constants in + Cmap_env.add kn (cs,ref None) env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in @@ -174,11 +174,9 @@ let evaluable_constant cst env = (* Mutual Inductives *) let lookup_mind = lookup_mind -let scrape_mind = scrape_mind - - + let add_mind kn mib env = - let new_inds = KNmap.add kn mib env.env_globals.env_inductives in + let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in let new_globals = { env.env_globals with env_inductives = new_inds } in @@ -276,30 +274,12 @@ let shallow_add_module mp mb env = env_modules = new_mods } in { env with env_globals = new_globals } -let rec scrape_alias mp env = - try - let mp1 = MPmap.find mp env.env_globals.env_alias in - scrape_alias mp1 env - with - Not_found -> mp - let lookup_module mp env = - let mp = scrape_alias mp env in MPmap.find mp env.env_globals.env_modules -let lookup_modtype ln env = - let mp = scrape_alias ln env in - MPmap.find mp env.env_globals.env_modtypes - -let register_alias mp1 mp2 env = - let new_alias = MPmap.add mp1 mp2 env.env_globals.env_alias in - let new_globals = - { env.env_globals with - env_alias = new_alias } in - { env with env_globals = new_globals } -let lookup_alias mp env = - MPmap.find mp env.env_globals.env_alias +let lookup_modtype mp env = + MPmap.find mp env.env_globals.env_modtypes (*s Judgments. *) diff --git a/kernel/environ.mli b/kernel/environ.mli index 0ae285528..9401ba6b0 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -142,9 +142,6 @@ val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env (* raises [Not_found] if the required path is not found *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body -(* Find the ultimate inductive in the [mind_equiv] chain *) -val scrape_mind : env -> mutual_inductive -> mutual_inductive - (************************************************************************) (*s Modules *) val add_modtype : module_path -> module_type_body -> env -> env @@ -155,10 +152,6 @@ val shallow_add_module : module_path -> module_body -> env -> env val lookup_module : module_path -> env -> module_body val lookup_modtype : module_path -> env -> module_type_body -val register_alias : module_path -> module_path -> env -> env -val lookup_alias : module_path -> env -> module_path -val scrape_alias : module_path -> env -> module_path - (************************************************************************) (*s Universe constraints *) val set_universes : Univ.universes -> env -> env diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index c202d627d..ffb6be771 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -651,8 +651,7 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_nparams_rec = nmr; mind_params_ctxt = params; mind_packets = packets; - mind_constraints = cst; - mind_equiv = None; + mind_constraints = cst } (************************************************************************) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 19e4130ff..8252f2d5a 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -362,20 +362,10 @@ let type_case_branches env (ind,largs) pj c = (************************************************************************) (* Checking the case annotation is relevent *) -let rec inductive_kn_equiv env kn1 kn2 = - match (lookup_mind kn1 env).mind_equiv with - | Some kn1' -> inductive_kn_equiv env kn2 kn1' - | None -> match (lookup_mind kn2 env).mind_equiv with - | Some kn2' -> inductive_kn_equiv env kn2' kn1 - | None -> false - -let inductive_equiv env (kn1,i1) (kn2,i2) = - i1=i2 & inductive_kn_equiv env kn1 kn2 - let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if - not (Closure.mind_equiv env indsp ci.ci_ind) or + not (eq_ind indsp ci.ci_ind) or (mib.mind_nparams <> ci.ci_npar) or (mip.mind_consnrealdecls <> ci.ci_cstr_nargs) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 238aa3544..a9d4a246d 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -13,27 +13,30 @@ open Util open Names open Term -(* WARNING: not every constant in the associative list domain used to exist - in the environment. This allows a simple implementation of the join - operation. However, iterating over the associative list becomes a non-sense -*) -type resolver = (constant * constr option) list - -let make_resolver resolve = resolve - -let apply_opt_resolver resolve kn = - match resolve with - None -> None - | Some resolve -> - try List.assoc kn resolve with Not_found -> None - -type substitution_domain = - MSI of mod_self_id + +type delta_hint = + Inline of constr option + | Equiv of kernel_name + | Prefix_equiv of module_path + +type delta_key = + KN of kernel_name + | MP of module_path + +module Deltamap = Map.Make(struct + type t = delta_key + let compare = Pervasives.compare + end) + +type delta_resolver = delta_hint Deltamap.t + +let empty_delta_resolver = Deltamap.empty + +type substitution_domain = | MBI of mod_bound_id | MPI of module_path let string_of_subst_domain = function - MSI msid -> debug_string_of_msid msid | MBI mbid -> debug_string_of_mbid mbid | MPI mp -> string_of_mp mp @@ -42,48 +45,233 @@ module Umap = Map.Make(struct let compare = Pervasives.compare end) -type substitution = (module_path * resolver option) Umap.t - +type substitution = (module_path * delta_resolver) Umap.t + let empty_subst = Umap.empty -let add_msid msid mp = - Umap.add (MSI msid) (mp,None) + +let string_of_subst_domain = function + | MBI mbid -> debug_string_of_mbid mbid + | MPI mp -> string_of_mp mp + let add_mbid mbid mp resolve = Umap.add (MBI mbid) (mp,resolve) -let add_mp mp1 mp2 = - Umap.add (MPI mp1) (mp2,None) +let add_mp mp1 mp2 resolve = + Umap.add (MPI mp1) (mp2,resolve) -let map_msid msid mp = add_msid msid mp empty_subst let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst -let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst +let map_mp mp1 mp2 resolve = add_mp mp1 mp2 resolve empty_subst + +let add_inline_delta_resolver con = + Deltamap.add (KN(user_con con)) (Inline None) + +let add_inline_constr_delta_resolver con cstr = + Deltamap.add (KN(user_con con)) (Inline (Some cstr)) + +let add_constant_delta_resolver con = + Deltamap.add (KN(user_con con)) (Equiv (canonical_con con)) + +let add_mind_delta_resolver mind = + Deltamap.add (KN(user_mind mind)) (Equiv (canonical_mind mind)) + +let add_mp_delta_resolver mp1 mp2 = + Deltamap.add (MP mp1) (Prefix_equiv mp2) + +let mp_in_delta mp = + Deltamap.mem (MP mp) + +let con_in_delta con resolver = +try + match Deltamap.find (KN(user_con con)) resolver with + | Inline _ | Prefix_equiv _ -> false + | Equiv _ -> true +with + Not_found -> false + +let mind_in_delta mind resolver = +try + match Deltamap.find (KN(user_mind mind)) resolver with + | Inline _ | Prefix_equiv _ -> false + | Equiv _ -> true +with + Not_found -> false + +let delta_of_mp resolve mp = + try + match Deltamap.find (MP mp) resolve with + | Prefix_equiv mp1 -> mp1 + | _ -> anomaly "mod_subst: bad association in delta_resolver" + with + Not_found -> mp + +let delta_of_kn resolve kn = + try + match Deltamap.find (KN kn) resolve with + | Equiv kn1 -> kn1 + | Inline _ -> kn + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + with + Not_found -> kn + +let remove_mp_delta_resolver resolver mp = + Deltamap.remove (MP mp) resolver + +exception Inline_kn + +let rec find_prefix resolve mp = + let rec sub_mp = function + | MPdot(mp,l) as mp_sup -> + (try + match Deltamap.find (MP mp_sup) resolve with + | Prefix_equiv mp1 -> mp1 + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + with + Not_found -> MPdot(sub_mp mp,l)) + | p -> + match Deltamap.find (MP p) resolve with + | Prefix_equiv mp1 -> mp1 + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + in + try + sub_mp mp + with + Not_found -> mp + +let solve_delta_kn resolve kn = + try + match Deltamap.find (KN kn) resolve with + | Equiv kn1 -> kn1 + | Inline _ -> raise Inline_kn + | _ -> anomaly + "mod_subst: bad association in delta_resolver" + with + Not_found | Inline_kn -> + let mp,dir,l = repr_kn kn in + let new_mp = find_prefix resolve mp in + if mp == new_mp then + kn + else + make_kn new_mp dir l + + +let constant_of_delta resolve con = + let kn = user_con con in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + con + else + constant_of_kn_equiv kn new_kn + +let constant_of_delta2 resolve con = + let kn = canonical_con con in + let kn1 = user_con con in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + con + else + constant_of_kn_equiv kn1 new_kn + +let mind_of_delta resolve mind = + let kn = user_mind mind in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + mind + else + mind_of_kn_equiv kn new_kn + +let mind_of_delta2 resolve mind = + let kn = canonical_mind mind in + let kn1 = user_mind mind in + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then + mind + else + mind_of_kn_equiv kn1 new_kn + + + +let inline_of_delta resolver = + let extract key hint l = + match key,hint with + |KN kn, Inline _ -> kn::l + | _,_ -> l + in + Deltamap.fold extract resolver [] -let list_contents sub = - let one_pair uid (mp,_) l = - (string_of_subst_domain uid, string_of_mp mp)::l +exception Not_inline + +let constant_of_delta_with_inline resolve con = + let kn1,kn2 = canonical_con con,user_con con in + try + match Deltamap.find (KN kn2) resolve with + | Inline None -> None + | Inline (Some const) -> Some const + | _ -> raise Not_inline + with + Not_found | Not_inline -> + try match Deltamap.find (KN kn1) resolve with + | Inline None -> None + | Inline (Some const) -> Some const + | _ -> raise Not_inline + with + Not_found | Not_inline -> None + +let string_of_key = function + | KN kn -> string_of_kn kn + | MP mp -> string_of_mp mp + +let string_of_hint = function + | Inline _ -> "inline" + | Equiv kn -> string_of_kn kn + | Prefix_equiv mp -> string_of_mp mp + +let debug_string_of_delta resolve = + let to_string key hint s = + s^", "^(string_of_key key)^"=>"^(string_of_hint hint) + in + Deltamap.fold to_string resolve "" + +let list_contents sub = + let one_pair uid (mp,reso) l = + (string_of_subst_domain uid, string_of_mp mp,debug_string_of_delta reso)::l in Umap.fold one_pair sub [] - + let debug_string_of_subst sub = - let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in + let l = List.map (fun (s1,s2,s3) -> s1^"|->"^s2^"["^s3^"]") + (list_contents sub) in "{" ^ String.concat "; " l ^ "}" + +let debug_pr_delta resolve = + str (debug_string_of_delta resolve) let debug_pr_subst sub = let l = list_contents sub in - let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) + let f (s1,s2,s3) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++ + spc () ++ str "[" ++ str s3 ++ str "]") in str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" - - + + let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with - | MPself sid -> - let mp',resolve = Umap.find (MSI sid) sub in + | MPfile sid -> + let mp',resolve = Umap.find (MPI (MPfile sid)) sub in mp',resolve | MPbound bid -> - let mp',resolve = Umap.find (MBI bid) sub in - mp',resolve + begin + try + let mp',resolve = Umap.find (MBI bid) sub in + mp',resolve + with Not_found -> + let mp',resolve = Umap.find (MPI mp) sub in + mp',resolve + end | MPdot (mp1,l) as mp2 -> begin try @@ -93,7 +281,6 @@ let subst_mp0 sub mp = (* 's like subst *) let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end - | _ -> raise Not_found in try Some (aux mp) @@ -104,39 +291,126 @@ let subst_mp sub mp = None -> mp | Some (mp',_) -> mp' - -let subst_kn0 sub kn = +let subst_kn_delta sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with - Some (mp',_) -> - Some (make_kn mp' dir l) - | None -> None + Some (mp',resolve) -> + solve_delta_kn resolve (make_kn mp' dir l) + | None -> kn + let subst_kn sub kn = - match subst_kn0 sub kn with - None -> kn - | Some kn' -> kn' + let mp,dir,l = repr_kn kn in + match subst_mp0 sub mp with + Some (mp',_) -> + (make_kn mp' dir l) + | None -> kn + +exception No_subst + +type sideconstantsubst = + | User + | Canonical + +let subst_ind sub mind = + let kn1,kn2 = user_mind mind,canonical_mind mind in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,mind',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_mind_equiv mp1' mp2' dir l), resolve2 + in + match side with + |User -> + let mind = mind_of_delta resolve mind' in + mind + |Canonical -> + let mind = mind_of_delta2 resolve mind' in + mind + with + No_subst -> mind + +let subst_mind0 sub mind = + let kn1,kn2 = user_mind mind,canonical_mind mind in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,mind',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_mind_equiv mp1' mp2' dir l), resolve2 + in + match side with + |User -> + let mind = mind_of_delta resolve mind' in + Some mind + |Canonical -> + let mind = mind_of_delta2 resolve mind' in + Some mind + with + No_subst -> Some mind let subst_con sub con = - let mp,dir,l = repr_con con in - match subst_mp0 sub mp with - None -> con,mkConst con - | Some (mp',resolve) -> - let con' = make_con mp' dir l in - match apply_opt_resolver resolve con with - None -> con',mkConst con' - | Some t -> con',t + let kn1,kn2 = user_con con,canonical_con con in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,con',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_con_equiv mp1' mp2' dir l), resolve2 + in + match constant_of_delta_with_inline resolve con' with + None -> begin + match side with + |User -> + let con = constant_of_delta resolve con' in + con,mkConst con + |Canonical -> + let con = constant_of_delta2 resolve con' in + con,mkConst con + end + | Some t -> con',t + with No_subst -> con , mkConst con + let subst_con0 sub con = - let mp,dir,l = repr_con con in - match subst_mp0 sub mp with - None -> None - | Some (mp',resolve) -> - let con' = make_con mp' dir l in - match apply_opt_resolver resolve con with - None -> Some (mkConst con') - | Some t -> Some t - + let kn1,kn2 = user_con con,canonical_con con in + let mp1,dir,l = repr_kn kn1 in + let mp2,_,_ = repr_kn kn2 in + try + let side,con',resolve = + match subst_mp0 sub mp1,subst_mp0 sub mp2 with + None,None ->raise No_subst + | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve + | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve + | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, + (make_con_equiv mp1' mp2' dir l), resolve2 + in + match constant_of_delta_with_inline resolve con' with + None ->begin + match side with + |User -> + let con = constant_of_delta resolve con' in + Some (mkConst con) + |Canonical -> + let con = constant_of_delta2 resolve con' in + Some (mkConst con) + end + | t -> t + with No_subst -> Some (mkConst con) + (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" @@ -220,7 +494,7 @@ let rec map_kn f f' c = | _ -> c let subst_mps sub = - map_kn (subst_kn0 sub) (subst_con0 sub) + map_kn (subst_mind0 sub) (subst_con0 sub) let rec replace_mp_in_mp mpfrom mpto mp = match mp with @@ -231,233 +505,145 @@ let rec replace_mp_in_mp mpfrom mpto mp = else MPdot (mp1',l) | _ -> mp -let replace_mp_in_con mpfrom mpto kn = - let mp,dir,l = repr_con kn in +let replace_mp_in_kn mpfrom mpto kn = + let mp,dir,l = repr_kn kn in let mp'' = replace_mp_in_mp mpfrom mpto mp in if mp==mp'' then kn - else make_con mp'' dir l - -exception BothSubstitutionsAreIdentitySubstitutions -exception ChangeDomain of resolver - -let join (subst1 : substitution) (subst2 : substitution) = - let apply_subst (sub : substitution) key (mp,resolve) = - let mp',resolve' = - match subst_mp0 sub mp with - None -> mp, None - | Some (mp',resolve') -> mp',resolve' in - let resolve'' : resolver option = - try - let res = - match resolve with - Some res -> res - | None -> - match resolve' with - None -> raise BothSubstitutionsAreIdentitySubstitutions - | Some res -> raise (ChangeDomain res) - in - Some - (List.map - (fun (kn,topt) -> - kn, - match topt with - None -> - (match key with - MSI msid -> - let kn' = replace_mp_in_con (MPself msid) mp kn in - apply_opt_resolver resolve' kn' - | MBI mbid -> - let kn' = replace_mp_in_con (MPbound mbid) mp kn in - apply_opt_resolver resolve' kn' - | MPI mp1 -> - let kn' = replace_mp_in_con mp1 mp kn in - apply_opt_resolver resolve' kn') - | Some t -> Some (subst_mps sub t)) res) - with - BothSubstitutionsAreIdentitySubstitutions -> None - | ChangeDomain res -> - let rec changeDom = function - | [] -> [] - | (kn,topt)::r -> - let key' = - match key with - MSI msid -> MPself msid - | MBI mbid -> MPbound mbid - | MPI mp1 -> mp1 in - let kn' = replace_mp_in_con mp key' kn in - if kn==kn' then - (*the key does not appear in kn, we remove it - from the resolver that we are building*) - changeDom r - else - (kn',topt)::(changeDom r) - in - Some (changeDom res) - in - mp',resolve'' in - let subst = Umap.mapi (apply_subst subst2) subst1 in - (Umap.fold Umap.add subst2 subst) - -let subst_key subst1 subst2 = - let replace_in_key key (mp,resolve) sub= - let newkey = - match key with - | MPI mp1 -> - begin - match subst_mp0 subst1 mp1 with - | None -> None - | Some (mp2,_) -> Some (MPI mp2) - end - | _ -> None - in - match newkey with - | None -> Umap.add key (mp,resolve) sub - | Some mpi -> Umap.add mpi (mp,resolve) sub + else make_kn mp'' dir l + +let mp_in_key mp key = + let rec mp_rec mp1 = + match mp1 with + | _ when mp1 = mp -> true + | MPdot (mp2,l) -> mp_rec mp2 + | _ -> false + in + match key with + | MP mp1 -> + mp_rec mp1 + | KN kn -> + let mp1,dir,l = repr_kn kn in + mp_rec mp1 + +let subset_prefixed_by mp resolver = + let prefixmp key hint resolv = + if mp_in_key mp key then + Deltamap.add key hint resolv + else + resolv in - Umap.fold replace_in_key subst2 empty_subst - -let update_subst_alias subst1 subst2 = - let subst_inv key (mp,resolve) sub = - let newmp = - match key with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - match mp with - | MPbound mbid -> Umap.add (MBI mbid) (newmp,None) sub - | MPself msid -> Umap.add (MSI msid) (newmp,None) sub - | _ -> Umap.add (MPI mp) (newmp,None) sub + Deltamap.fold prefixmp resolver empty_delta_resolver + +let subst_dom_delta_resolver subst resolver = + let apply_subst key hint resolver = + match key with + (MP mp) -> + Deltamap.add (MP (subst_mp subst mp)) hint resolver + | (KN kn) -> + Deltamap.add (KN (subst_kn subst kn)) hint resolver in - let subst_mbi = Umap.fold subst_inv subst2 empty_subst in - let alias_subst key (mp,resolve) sub= - let newkey = - match key with - | MPI mp1 -> - begin - match subst_mp0 subst_mbi mp1 with - | None -> None - | Some (mp2,_) -> Some (MPI mp2) - end - | _ -> None - in - match newkey with - | None -> Umap.add key (mp,resolve) sub - | Some mpi -> Umap.add mpi (mp,resolve) sub + Deltamap.fold apply_subst resolver empty_delta_resolver + +let subst_mp_delta sub mp key= + match subst_mp0 sub mp with + None -> empty_delta_resolver,mp + | Some (mp',resolve) -> + let mp1 = find_prefix resolve mp' in + let resolve1 = subset_prefixed_by mp1 resolve in + match key with + MP mpk -> + (subst_dom_delta_resolver + (map_mp mp1 mpk empty_delta_resolver) resolve1),mp1 + | _ -> anomaly "Mod_subst: Bad association in resolver" + +let subst_codom_delta_resolver subst resolver = + let apply_subst key hint resolver = + match hint with + Prefix_equiv mp -> + let derived_resolve,mpnew = subst_mp_delta subst mp key in + Deltamap.fold Deltamap.add derived_resolve + (Deltamap.add key (Prefix_equiv mpnew) resolver) + | (Equiv kn) -> + Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver + | Inline None -> + Deltamap.add key hint resolver + | Inline (Some t) -> + Deltamap.add key (Inline (Some (subst_mps subst t))) resolver in - Umap.fold alias_subst subst1 empty_subst - -let update_subst subst1 subst2 = - let subst_inv key (mp,resolve) l = - let newmp = - match key with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - match mp with - | MPbound mbid -> ((MBI mbid),newmp,resolve)::l - | MPself msid -> ((MSI msid),newmp,resolve)::l - | _ -> ((MPI mp),newmp,resolve)::l + Deltamap.fold apply_subst resolver empty_delta_resolver + +let subst_dom_codom_delta_resolver subst resolver = + let apply_subst key hint resolver = + match key,hint with + (MP mp1),Prefix_equiv mp -> + let key = MP (subst_mp subst mp1) in + let derived_resolve,mpnew = subst_mp_delta subst mp key in + Deltamap.fold Deltamap.add derived_resolve + (Deltamap.add key (Prefix_equiv mpnew) resolver) + | (KN kn1),(Equiv kn) -> + let key = KN (subst_kn subst kn1) in + Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver + | (KN kn),Inline None -> + let key = KN (subst_kn subst kn) in + Deltamap.add key hint resolver + | (KN kn),Inline (Some t) -> + let key = KN (subst_kn subst kn) in + Deltamap.add key (Inline (Some (subst_mps subst t))) resolver + | _,_ -> anomaly "Mod_subst: Bad association in resolver" in - let subst_mbi = Umap.fold subst_inv subst2 [] in - let alias_subst key (mp,resolve) sub= - let newsetkey = - match key with - | MPI mp1 -> - let compute_set_newkey l (k,mp',resolve) = - let mp_from_key = match k with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - let new_mp1 = replace_mp_in_mp mp_from_key mp' mp1 in - if new_mp1 == mp1 then l else (MPI new_mp1,resolve)::l - in - begin - match List.fold_left compute_set_newkey [] subst_mbi with - | [] -> None - | l -> Some (l) - end - | _ -> None + Deltamap.fold apply_subst resolver empty_delta_resolver + +let update_delta_resolver resolver1 resolver2 = + let apply_res key hint res = + try + match hint with + Prefix_equiv mp -> + let new_hint = + Prefix_equiv (find_prefix resolver2 mp) + in Deltamap.add key new_hint res + | Equiv kn -> + let new_hint = + Equiv (solve_delta_kn resolver2 kn) + in Deltamap.add key new_hint res + | _ -> Deltamap.add key hint res + with not_found -> + Deltamap.add key hint res in - match newsetkey with - | None -> sub - | Some l -> - List.fold_left (fun s (k,r) -> Umap.add k (mp,r) s) - sub l - in - Umap.fold alias_subst subst1 empty_subst + Deltamap.fold apply_res resolver1 empty_delta_resolver + +let add_delta_resolver resolver1 resolver2 = + if resolver1 == resolver2 then + resolver2 + else if resolver2 = empty_delta_resolver then + resolver1 + else + Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2) + resolver2 -let join_alias (subst1 : substitution) (subst2 : substitution) = +let join (subst1 : substitution) (subst2 : substitution) = let apply_subst (sub : substitution) key (mp,resolve) = let mp',resolve' = match subst_mp0 sub mp with None -> mp, None - | Some (mp',resolve') -> mp',resolve' in - let resolve'' : resolver option = - try - let res = - match resolve with - Some res -> res - | None -> - match resolve' with - None -> raise BothSubstitutionsAreIdentitySubstitutions - | Some res -> raise (ChangeDomain res) - in - Some - (List.map - (fun (kn,topt) -> - kn, - match topt with - None -> - (match key with - MSI msid -> - let kn' = replace_mp_in_con (MPself msid) mp kn in - apply_opt_resolver resolve' kn' - | MBI mbid -> - let kn' = replace_mp_in_con (MPbound mbid) mp kn in - apply_opt_resolver resolve' kn' - | MPI mp1 -> - let kn' = replace_mp_in_con mp1 mp kn in - apply_opt_resolver resolve' kn') - | Some t -> Some (subst_mps sub t)) res) - with - BothSubstitutionsAreIdentitySubstitutions -> None - | ChangeDomain res -> - let rec changeDom = function - | [] -> [] - | (kn,topt)::r -> - let key' = - match key with - MSI msid -> MPself msid - | MBI mbid -> MPbound mbid - | MPI mp1 -> mp1 in - let kn' = replace_mp_in_con mp key' kn in - if kn==kn' then - (*the key does not appear in kn, we remove it - from the resolver that we are building*) - changeDom r - else - (kn',topt)::(changeDom r) - in - Some (changeDom res) + | Some (mp',resolve') -> mp' + ,Some resolve' in + let resolve'' : delta_resolver = + match resolve' with + Some res -> + add_delta_resolver + (subst_dom_codom_delta_resolver sub resolve) + res + | None -> + subst_codom_delta_resolver sub resolve in mp',resolve'' in - Umap.mapi (apply_subst subst2) subst1 + let subst = Umap.mapi (apply_subst subst2) subst1 in + (Umap.fold Umap.add subst2 subst) -let remove_alias subst = - let rec remove key (mp,resolve) sub = - match key with - MPI _ -> sub - | _ -> Umap.add key (mp,resolve) sub - in - Umap.fold remove subst empty_subst let rec occur_in_path uid path = match uid,path with - | MSI sid,MPself sid' -> sid = sid' | MBI bid,MPbound bid' -> bid = bid' | _,MPdot (mp1,_) -> occur_in_path uid mp1 | _ -> false @@ -471,7 +657,7 @@ let occur_uid uid sub = false with Exit -> true -let occur_msid uid = occur_uid (MSI uid) + let occur_mbid uid = occur_uid (MBI uid) type 'a lazy_subst = diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index d30168a1b..a948d1647 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -13,26 +13,74 @@ open Names open Term -type resolver +(* A delta_resolver maps name (constant, inductive, module_path) + to canonical name *) +type delta_resolver + type substitution -val make_resolver : (constant * constr option) list -> resolver +val empty_delta_resolver : delta_resolver + +val add_inline_delta_resolver : constant -> delta_resolver -> delta_resolver + +val add_inline_constr_delta_resolver : constant -> constr -> delta_resolver + -> delta_resolver + +val add_constant_delta_resolver : constant -> delta_resolver -> delta_resolver + +val add_mind_delta_resolver : mutual_inductive -> delta_resolver -> delta_resolver + +val add_mp_delta_resolver : module_path -> module_path -> delta_resolver + -> delta_resolver + +val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver + +(* Apply the substitution on the domain of the resolver *) +val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver + +(* Apply the substitution on the codomain of the resolver *) +val subst_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver + +val subst_dom_codom_delta_resolver : + substitution -> delta_resolver -> delta_resolver + +(* *_of_delta return the associated name of arg2 in arg1 *) +val constant_of_delta : delta_resolver -> constant -> constant + +val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive + +val delta_of_mp : delta_resolver -> module_path -> module_path + +(* Extract the set of inlined constant in the resolver *) +val inline_of_delta : delta_resolver -> kernel_name list + +(* remove_mp is used for the computation of a resolver induced by Include P *) +val remove_mp_delta_resolver : delta_resolver -> module_path -> delta_resolver + + +(* mem tests *) +val mp_in_delta : module_path -> delta_resolver -> bool + +val con_in_delta : constant -> delta_resolver -> bool + +val mind_in_delta : mutual_inductive -> delta_resolver -> bool + +(*substitution*) val empty_subst : substitution -val add_msid : - mod_self_id -> module_path -> substitution -> substitution +(* add_* add [arg2/arg1]{arg3} to the substitution with no + sequential composition *) val add_mbid : - mod_bound_id -> module_path -> resolver option -> substitution -> substitution + mod_bound_id -> module_path -> delta_resolver -> substitution -> substitution val add_mp : - module_path -> module_path -> substitution -> substitution + module_path -> module_path -> delta_resolver -> substitution -> substitution -val map_msid : - mod_self_id -> module_path -> substitution +(* map_* create a new substitution [arg2/arg1]{arg3} *) val map_mbid : - mod_bound_id -> module_path -> resolver option -> substitution + mod_bound_id -> module_path -> delta_resolver -> substitution val map_mp : - module_path -> module_path -> substitution + module_path -> module_path -> delta_resolver -> substitution (* sequential composition: [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] @@ -47,6 +95,8 @@ val subst_substituted : substitution -> 'a substituted -> 'a substituted (*i debugging *) val debug_string_of_subst : substitution -> string val debug_pr_subst : substitution -> Pp.std_ppcmds +val debug_string_of_delta : delta_resolver -> string +val debug_pr_delta : delta_resolver -> Pp.std_ppcmds (*i*) (* [subst_mp sub mp] guarantees that whenever the result of the @@ -56,7 +106,10 @@ val debug_pr_subst : substitution -> Pp.std_ppcmds val subst_mp : substitution -> module_path -> module_path -val subst_kn : +val subst_ind : + substitution -> mutual_inductive -> mutual_inductive + +val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : @@ -71,7 +124,7 @@ val subst_evaluable_reference : substitution -> evaluable_global_reference -> evaluable_global_reference (* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) -val replace_mp_in_con : module_path -> module_path -> constant -> constant +val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name (* [subst_mps sub c] performs the substitution [sub] on all kernel names appearing in [c] *) @@ -80,15 +133,5 @@ val subst_mps : substitution -> constr -> constr (* [occur_*id id sub] returns true iff [id] occurs in [sub] on either side *) -val occur_msid : mod_self_id -> substitution -> bool val occur_mbid : mod_bound_id -> substitution -> bool -val update_subst_alias : substitution -> substitution -> substitution - -val update_subst : substitution -> substitution -> substitution - -val subst_key : substitution -> substitution -> substitution - -val join_alias : substitution -> substitution -> substitution - -val remove_alias : substitution -> substitution diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 3d55fb69a..48928470a 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -37,52 +37,32 @@ let rec list_fold_map2 f e = function let e'',t1',t2' = list_fold_map2 f e' t in e'',h1'::t1',h2'::t2' +let discr_resolver env mtb = + match mtb.typ_expr with + SEBstruct _ -> + mtb.typ_delta + | _ -> (*case mp is a functor *) + empty_delta_resolver + let rec rebuild_mp mp l = match l with []-> mp - | i::r -> rebuild_mp (MPdot(mp,i)) r - -let type_of_struct env b meb = - let rec aux env = function - | SEBfunctor (mp,mtb,body) -> - let env = add_module (MPbound mp) (module_body_of_type mtb) env in - SEBfunctor(mp,mtb, aux env body) - | SEBident mp -> - strengthen env (lookup_modtype mp env).typ_expr mp - | SEBapply _ as mtb -> eval_struct env mtb - | str -> str - in - if b then - Some (aux env meb) - else - None - -let rec bounded_str_expr = function - | SEBfunctor (mp,mtb,body) -> bounded_str_expr body - | SEBident mp -> (check_bound_mp mp) - | SEBapply (f,a,_)->(bounded_str_expr f) - | _ -> false - -let return_opt_type mp env mtb = - if (check_bound_mp mp) then - Some (strengthen env mtb.typ_expr mp) - else - None - -let rec check_with env mtb with_decl = + | i::r -> rebuild_mp (MPdot(mp,i)) r + +let rec check_with env sign with_decl alg_sign mp equiv = match with_decl with | With_Definition (id,_) -> - let cb = check_with_aux_def env mtb with_decl in - SEBwith(mtb,With_definition_body(id,cb)),empty_subst - | With_Module (id,mp) -> - let cst,sub,typ_opt = check_with_aux_mod env mtb with_decl true in - SEBwith(mtb,With_module_body(id,mp,typ_opt,cst)),sub - -and check_with_aux_def env mtb with_decl = - let msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) -> - msid,sig_b - | _ -> error_signature_expected mtb + let sign,cb,cst = check_with_aux_def env sign with_decl mp equiv in + sign,Some (SEBwith(alg_sign,With_definition_body(id,cb))),equiv,cst + | With_Module (id,mp1) -> + let sign,equiv,cst = + check_with_aux_mod env sign with_decl mp equiv in + sign,Some (SEBwith(alg_sign,With_module_body(id,mp1))),equiv,cst + +and check_with_aux_def env sign with_decl mp equiv = + let sig_b = match sign with + | SEBstruct(sig_b) -> sig_b + | _ -> error_signature_expected sign in let id,idl = match with_decl with | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl @@ -92,7 +72,7 @@ and check_with_aux_def env mtb with_decl = try let rev_before,spec,after = list_split_assoc l [] sig_b in let before = List.rev rev_before in - let env' = Modops.add_signature (MPself msid) before env in + let env' = Modops.add_signature mp before equiv env in match with_decl with | With_Definition ([],_) -> assert false | With_Definition ([id],c) -> @@ -116,7 +96,7 @@ and check_with_aux_def env mtb with_decl = const_body_code = Cemitcodes.from_val (compile_constant_body env' body false false); const_constraints = cst} in - cb' + SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst | Some b -> let cst1 = Reduction.conv env' c (Declarations.force b) in let cst = Constraint.union cb.const_constraints cst1 in @@ -126,9 +106,9 @@ and check_with_aux_def env mtb with_decl = const_body_code = Cemitcodes.from_val (compile_constant_body env' body false false); const_constraints = cst} in - cb' + SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst end - | With_Definition (_::_,_) -> + | With_Definition (_::_,c) -> let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) @@ -136,10 +116,14 @@ and check_with_aux_def env mtb with_decl = begin match old.mod_expr with | None -> - let new_with_decl = match with_decl with - With_Definition (_,c) -> With_Definition (idl,c) - | With_Module (_,c) -> With_Module (idl,c) in - check_with_aux_def env' (type_of_mb env old) new_with_decl + let new_with_decl = With_Definition (idl,c) in + let sign,cb,cst = + check_with_aux_def env' old.mod_type new_with_decl + (MPdot(mp,l)) old.mod_delta in + let new_spec = SFBmodule({old with + mod_type = sign; + mod_type_alg = None}) in + SEBstruct(before@((l,new_spec)::after)),cb,cst | Some msb -> error_a_generative_module_expected l end @@ -148,11 +132,10 @@ and check_with_aux_def env mtb with_decl = Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl now = - let initmsid,msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) ->let msid'=(refresh_msid msid) in - msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b) - | _ -> error_signature_expected mtb +and check_with_aux_mod env sign with_decl mp equiv = + let sig_b = match sign with + | SEBstruct(sig_b) ->sig_b + | _ -> error_signature_expected sign in let id,idl = match with_decl with | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl @@ -163,172 +146,234 @@ and check_with_aux_mod env mtb with_decl now = let rev_before,spec,after = list_split_assoc l [] sig_b in let before = List.rev rev_before in let rec mp_rec = function - | [] -> MPself initmsid + | [] -> mp | i::r -> MPdot(mp_rec r,label_of_id i) in - let env' = Modops.add_signature (MPself msid) before env in + let env' = Modops.add_signature mp before equiv env in match with_decl with | With_Module ([],_) -> assert false - | With_Module ([id], mp) -> - let old,alias = match spec with - SFBmodule msb -> Some msb,None - | SFBalias (mp',_,cst) -> None,Some (mp',cst) + | With_Module ([id], mp1) -> + let old = match spec with + SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) in - let mtb' = lookup_modtype mp env' in + let mb_mp1 = (lookup_module mp1 env) in + let mtb_mp1 = + module_type_of_module env' None mb_mp1 in let cst = - match old,alias with - Some msb,None -> + match old.mod_expr with + None -> begin try Constraint.union - (check_subtypes env' mtb' (module_type_of_module None msb)) - msb.mod_constraints + (check_subtypes env' mtb_mp1 + (module_type_of_module env' None old)) + old.mod_constraints with Failure _ -> error_with_incorrect (label_of_id id) end - | None,Some (mp',None) -> - check_modpath_equiv env' mp mp'; - Constraint.empty - | None,Some (mp',Some cst) -> - check_modpath_equiv env' mp mp'; - cst - | _,_ -> - anomaly "Mod_typing:no implementation and no alias" + | Some (SEBident(mp')) -> + check_modpath_equiv env' mp1 mp'; + old.mod_constraints + | _ -> error_a_generative_module_expected l + in + let new_mb = strengthen_and_subst_mb mb_mp1 + (MPdot(mp,l)) env false in + let new_spec = SFBmodule {new_mb with + mod_mp = MPdot(mp,l); + mod_expr = Some (SEBident mp1); + mod_constraints = cst} in + (* we propagate the new equality in the rest of the signature + with the identity substitution accompagned by the new resolver*) + let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in + SEBstruct(before@(l,new_spec)::subst_signature id_subst after), + add_delta_resolver equiv new_mb.mod_delta,cst + | With_Module (idc,mp1) -> + let old = match spec with + SFBmodule msb -> msb + | _ -> error_not_a_module (string_of_label l) in - if now then - let mp' = scrape_alias mp env' in - let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in - let up_subst = update_subst sub (map_mp (mp_rec [id]) mp') in - cst, (join (map_mp (mp_rec [id]) mp') up_subst),(return_opt_type mp env' mtb') - else - cst,empty_subst,(return_opt_type mp env' mtb') - | With_Module (_::_,mp) -> - let old,alias = match spec with - SFBmodule msb -> Some msb, None - | SFBalias (mpold,typ_opt,cst)->None, Some mpold - | _ -> error_not_a_module (string_of_label l) - in begin - if alias = None then - let old = Option.get old in - match old.mod_expr with - None -> - let new_with_decl = match with_decl with - With_Definition (_,c) -> - With_Definition (idl,c) - | With_Module (_,c) -> With_Module (idl,c) in - let cst,_,typ_opt = - check_with_aux_mod env' - (type_of_mb env' old) new_with_decl false in - if now then - let mtb' = lookup_modtype mp env' in - let mp' = scrape_alias mp env' in - let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in - let up_subst = update_subst - sub (map_mp (mp_rec (List.rev (id::idl))) mp') in - cst, - (join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst), - typ_opt - else - cst,empty_subst,typ_opt - | Some msb -> - error_a_generative_module_expected l - else - let mpold = Option.get alias in - let mpnew = rebuild_mp mpold (List.map label_of_id idl) in - check_modpath_equiv env' mpnew mp; - let mtb' = lookup_modtype mp env' in - Constraint.empty,empty_subst,(return_opt_type mp env' mtb') + match old.mod_expr with + None -> + let new_with_decl = With_Module (idl,mp1) in + let sign,equiv',cst = + check_with_aux_mod env' + old.mod_type new_with_decl (MPdot(mp,l)) old.mod_delta in + let new_equiv = add_delta_resolver equiv equiv' in + let new_spec = SFBmodule {old with + mod_type = sign; + mod_type_alg = None; + mod_delta = equiv'} + in + let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) equiv' in + SEBstruct(before@(l,new_spec)::subst_signature id_subst after), + new_equiv,cst + | Some (SEBident(mp')) -> + let mpnew = rebuild_mp mp' (List.map label_of_id idl) in + check_modpath_equiv env' mpnew mp; + SEBstruct(before@(l,spec)::after) + ,equiv,Constraint.empty + | _ -> + error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" + | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and translate_module env me = +and translate_module env mp me = match me.mod_entry_expr, me.mod_entry_type with | None, None -> anomaly "Mod_typing.translate_module: empty type and expr in module entry" | None, Some mte -> - let mtb,sub = translate_struct_entry env mte in - { mod_expr = None; - mod_type = Some mtb; - mod_alias = sub; - mod_constraints = Constraint.empty; - mod_retroknowledge = []} - | Some mexpr, _ -> - let meb,sub1 = translate_struct_entry env mexpr in - let mod_typ,sub,cst = + let mtb = translate_module_type env mp mte in + { mod_mp = mp; + mod_expr = None; + mod_type = mtb.typ_expr; + mod_type_alg = mtb.typ_expr_alg; + mod_delta = mtb.typ_delta; + mod_constraints = mtb.typ_constraints; + mod_retroknowledge = []} + | Some mexpr, _ -> + let sign,alg_implem,resolver,cst1 = + translate_struct_module_entry env mp mexpr in + let sign,alg1,resolver,cst2 = match me.mod_entry_type with | None -> - (type_of_struct env (bounded_str_expr meb) meb) - ,sub1,Constraint.empty + sign,None,resolver,Constraint.empty | Some mte -> - let mtb2,sub2 = translate_struct_entry env mte in + let mtb = translate_module_type env mp mte in let cst = check_subtypes env - {typ_expr = meb; - typ_strength = None; - typ_alias = sub1;} - {typ_expr = mtb2; - typ_strength = None; - typ_alias = sub2;} + {typ_mp = mp; + typ_expr = sign; + typ_expr_alg = None; + typ_constraints = Constraint.empty; + typ_delta = resolver;} + mtb in - Some mtb2,sub2,cst + mtb.typ_expr,mtb.typ_expr_alg,mtb.typ_delta,cst in - { mod_type = mod_typ; - mod_expr = Some meb; - mod_constraints = cst; - mod_alias = sub; - mod_retroknowledge = []} (* spiwack: not so sure about that. It may - cause a bug when closing nested modules. - If it does, I don't really know how to - fix the bug.*) - - -and translate_struct_entry env mse = match mse with - | MSEident mp -> - let mtb = lookup_modtype mp env in - SEBident mp,mtb.typ_alias + { mod_mp = mp; + mod_type = sign; + mod_expr = Some alg_implem; + mod_type_alg = alg1; + mod_constraints = Univ.Constraint.union cst1 cst2; + mod_delta = resolver; + mod_retroknowledge = []} + (* spiwack: not so sure about that. It may + cause a bug when closing nested modules. + If it does, I don't really know how to + fix the bug.*) + + +and translate_struct_module_entry env mp mse = match mse with + | MSEident mp1 -> + let mb = lookup_module mp1 env in + let mb' = strengthen_and_subst_mb mb mp env false in + mb'.mod_type, SEBident mp1, mb'.mod_delta,Univ.Constraint.empty | MSEfunctor (arg_id, arg_e, body_expr) -> - let arg_b,sub = translate_struct_entry env arg_e in - let mtb = - {typ_expr = arg_b; - typ_strength = None; - typ_alias = sub} in - let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in - let body_b,sub = translate_struct_entry env' body_expr in - SEBfunctor (arg_id, mtb, body_b),sub + let mtb = translate_module_type env (MPbound arg_id) arg_e in + let env' = add_module (module_body_of_type (MPbound arg_id) mtb) + env in + let sign,alg,resolver,cst = translate_struct_module_entry env' + mp body_expr in + SEBfunctor (arg_id, mtb, sign),SEBfunctor (arg_id, mtb, alg),resolver, + Univ.Constraint.union cst mtb.typ_constraints | MSEapply (fexpr,mexpr) -> - let feb,sub1 = translate_struct_entry env fexpr in - let feb'= eval_struct env feb - in - let farg_id, farg_b, fbody_b = destr_functor env feb' in - let mtb,mp = + let sign,alg,resolver,cst1 = translate_struct_module_entry env mp fexpr in + let farg_id, farg_b, fbody_b = destr_functor env sign in + let mtb,mp1 = try - let mp = scrape_alias (path_of_mexpr mexpr) env in - lookup_modtype mp env,mp + let mp1 = path_of_mexpr mexpr in + let mtb = module_type_of_module env None (lookup_module mp1 env) in + mtb,mp1 with | Not_path -> error_application_to_not_path mexpr (* place for nondep_supertype *) in - let meb,sub2= translate_struct_entry env (MSEident mp) in - if sub1 = empty_subst then - let cst = check_subtypes env mtb farg_b in - SEBapply(feb,meb,cst),sub1 - else - let sub2 = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> - join_alias - (subst_key (map_msid msid mp) sub2) - (map_msid msid mp) - | _ -> sub2 in - let sub3 = join_alias sub1 (map_mbid farg_id mp None) in - let sub4 = update_subst sub2 sub3 in - let cst = check_subtypes env mtb farg_b in - SEBapply(feb,meb,cst),(join sub3 sub4) + let cst = check_subtypes env mtb farg_b in + let mp_delta = discr_resolver env mtb in + let mp_delta = complete_inline_delta_resolver env mp1 + farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta in + (subst_struct_expr subst fbody_b),SEBapply(alg,SEBident mp1,cst), + (subst_codom_delta_resolver subst resolver), + Univ.Constraint.union cst1 cst | MSEwith(mte, with_decl) -> - let mtb,sub1 = translate_struct_entry env mte in - let mtb',sub2 = check_with env mtb with_decl in - mtb',join sub1 sub2 - + let sign,alg,resolve,cst1 = translate_struct_module_entry env mp mte in + let sign,alg,resolve,cst2 = check_with env sign with_decl alg mp resolve in + sign,Option.get alg,resolve,Univ.Constraint.union cst1 cst2 + +and translate_struct_type_entry env mse = match mse with + | MSEident mp1 -> + let mtb = lookup_modtype mp1 env in + mtb.typ_expr, + Some (SEBident mp1),mtb.typ_delta,mp1,Univ.Constraint.empty + | MSEfunctor (arg_id, arg_e, body_expr) -> + let mtb = translate_module_type env (MPbound arg_id) arg_e in + let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in + let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env' + body_expr in + SEBfunctor (arg_id, mtb, sign),None,resolve,mp_from, + Univ.Constraint.union cst mtb.typ_constraints + | MSEapply (fexpr,mexpr) -> + let sign,alg,resolve,mp_from,cst1 = translate_struct_type_entry env fexpr in + let farg_id, farg_b, fbody_b = destr_functor env sign in + let mtb,mp1 = + try + let mp1 = path_of_mexpr mexpr in + let mtb = module_type_of_module env None (lookup_module mp1 env) in + mtb,mp1 + with + | Not_path -> error_application_to_not_path mexpr + (* place for nondep_supertype *) in + let cst2 = check_subtypes env mtb farg_b in + let mp_delta = discr_resolver env mtb in + let mp_delta = complete_inline_delta_resolver env mp1 + farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta in + (subst_struct_expr subst fbody_b),None, + (subst_codom_delta_resolver subst resolve),mp_from,Univ.Constraint.union cst1 cst2 + | MSEwith(mte, with_decl) -> + let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env mte in + let sign,alg,resolve,cst1 = + check_with env sign with_decl (Option.get alg) mp_from resolve in + sign,alg,resolve,mp_from,Univ.Constraint.union cst cst1 + +and translate_module_type env mp mte = + let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env mte in + subst_modtype_and_resolver + {typ_mp = mp_from; + typ_expr = sign; + typ_expr_alg = alg; + typ_constraints = cst; + typ_delta = resolve} mp env + +let rec translate_struct_include_module_entry env mp mse = match mse with + | MSEident mp1 -> + let mb = lookup_module mp1 env in + let mb' = strengthen_and_subst_mb mb mp env true in + mb'.mod_type, mb'.mod_delta,Univ.Constraint.empty + | MSEapply (fexpr,mexpr) -> + let sign,resolver,cst1 = + translate_struct_include_module_entry env mp fexpr in + let farg_id, farg_b, fbody_b = destr_functor env sign in + let mtb,mp1 = + try + let mp1 = path_of_mexpr mexpr in + let mtb = module_type_of_module env None (lookup_module mp1 env) in + mtb,mp1 + with + | Not_path -> error_application_to_not_path mexpr + (* place for nondep_supertype *) in + let cst = check_subtypes env mtb farg_b in + let mp_delta = discr_resolver env mtb in + let mp_delta = complete_inline_delta_resolver env mp1 + farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta in + (subst_struct_expr subst fbody_b), + (subst_codom_delta_resolver subst resolver), + Univ.Constraint.union cst1 cst + | _ -> error ("You cannot Include a high-order structure.") + let rec add_struct_expr_constraints env = function | SEBident _ -> env @@ -337,7 +382,7 @@ let rec add_struct_expr_constraints env = function add_struct_expr_constraints (add_modtype_constraints env mtb) meb - | SEBstruct (_,structure_body) -> + | SEBstruct (structure_body) -> List.fold_left (fun env (l,item) -> add_struct_elem_constraints env item) env @@ -351,16 +396,13 @@ let rec add_struct_expr_constraints env = function | SEBwith(meb,With_definition_body(_,cb))-> Environ.add_constraints cb.const_constraints (add_struct_expr_constraints env meb) - | SEBwith(meb,With_module_body(_,_,_,cst))-> - Environ.add_constraints cst - (add_struct_expr_constraints env meb) - -and add_struct_elem_constraints env = function + | SEBwith(meb,With_module_body(_,_))-> + add_struct_expr_constraints env meb + +and add_struct_elem_constraints env = function | SFBconst cb -> Environ.add_constraints cb.const_constraints env | SFBmind mib -> Environ.add_constraints mib.mind_constraints env | SFBmodule mb -> add_module_constraints env mb - | SFBalias (mp,_,Some cst) -> Environ.add_constraints cst env - | SFBalias (mp,_,None) -> env | SFBmodtype mtb -> add_modtype_constraints env mtb and add_module_constraints env mb = @@ -368,15 +410,14 @@ and add_module_constraints env mb = | None -> env | Some meb -> add_struct_expr_constraints env meb in - let env = match mb.mod_type with - | None -> env - | Some mtb -> - add_struct_expr_constraints env mtb + let env = + add_struct_expr_constraints env mb.mod_type in Environ.add_constraints mb.mod_constraints env and add_modtype_constraints env mtb = - add_struct_expr_constraints env mtb.typ_expr + Environ.add_constraints mtb.typ_constraints + (add_struct_expr_constraints env mtb.typ_expr) let rec struct_expr_constraints cst = function @@ -386,7 +427,7 @@ let rec struct_expr_constraints cst = function struct_expr_constraints (modtype_constraints cst mtb) meb - | SEBstruct (_,structure_body) -> + | SEBstruct (structure_body) -> List.fold_left (fun cst (l,item) -> struct_elem_constraints cst item) cst @@ -399,28 +440,25 @@ let rec struct_expr_constraints cst = function | SEBwith(meb,With_definition_body(_,cb))-> struct_expr_constraints (Univ.Constraint.union cb.const_constraints cst) meb - | SEBwith(meb,With_module_body(_,_,_,cst1))-> - struct_expr_constraints (Univ.Constraint.union cst1 cst) meb - -and struct_elem_constraints cst = function + | SEBwith(meb,With_module_body(_,_))-> + struct_expr_constraints cst meb + +and struct_elem_constraints cst = function | SFBconst cb -> cst | SFBmind mib -> cst | SFBmodule mb -> module_constraints cst mb - | SFBalias (mp,_,Some cst1) -> Univ.Constraint.union cst1 cst - | SFBalias (mp,_,None) -> cst | SFBmodtype mtb -> modtype_constraints cst mtb and module_constraints cst mb = let cst = match mb.mod_expr with | None -> cst | Some meb -> struct_expr_constraints cst meb in - let cst = match mb.mod_type with - | None -> cst - | Some mtb -> struct_expr_constraints cst mtb in + let cst = + struct_expr_constraints cst mb.mod_type in Univ.Constraint.union mb.mod_constraints cst and modtype_constraints cst mtb = - struct_expr_constraints cst mtb.typ_expr + struct_expr_constraints (Univ.Constraint.union mtb.typ_constraints cst) mtb.typ_expr let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index 1fadec2ad..746a80e15 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -13,13 +13,24 @@ open Declarations open Environ open Entries open Mod_subst +open Names (*i*) -val translate_module : env -> module_entry -> module_body +val translate_module : env -> module_path -> module_entry + -> module_body -val translate_struct_entry : env -> module_struct_entry -> - struct_expr_body * substitution +val translate_module_type : env -> module_path -> module_struct_entry -> + module_type_body + +val translate_struct_module_entry : env -> module_path -> module_struct_entry -> + struct_expr_body * struct_expr_body * delta_resolver * Univ.constraints + +val translate_struct_type_entry : env -> module_struct_entry -> + struct_expr_body * struct_expr_body option * delta_resolver * module_path * Univ.constraints + +val translate_struct_include_module_entry : env -> module_path + -> module_struct_entry -> struct_expr_body * delta_resolver * Univ.constraints val add_modtype_constraints : env -> module_type_body -> env diff --git a/kernel/modops.ml b/kernel/modops.ml index 3f38cc2f7..8193c02e5 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -22,7 +22,7 @@ open Mod_subst -let error_existing_label l = +let error_existing_label l = error ("The label "^string_of_label l^" is already declared.") let error_declaration_not_path _ = error "Declaration is not a path." @@ -39,31 +39,31 @@ let error_not_match l _ = error ("Signature components for label "^string_of_lab let error_no_such_label l = error ("No such label "^string_of_label l^".") -let error_incompatible_labels l l' = +let error_incompatible_labels l l' = error ("Opening and closing labels are not the same: " ^string_of_label l^" <> "^string_of_label l'^" !") -let error_result_must_be_signature () = +let error_result_must_be_signature () = error "The result module type must be a signature." let error_signature_expected mtb = error "Signature expected." -let error_no_module_to_end _ = +let error_no_module_to_end _ = error "No open module to end." let error_no_modtype_to_end _ = error "No open module type to end." -let error_not_a_modtype_loc loc s = +let error_not_a_modtype_loc loc s = user_err_loc (loc,"",str ("\""^s^"\" is not a module type.")) -let error_not_a_module_loc loc s = +let error_not_a_module_loc loc s = user_err_loc (loc,"",str ("\""^s^"\" is not a module.")) let error_not_a_module s = error_not_a_module_loc dummy_loc s -let error_not_a_constant l = +let error_not_a_constant l = error ("\""^(string_of_label l)^"\" is not a constant.") let error_with_incorrect l = @@ -74,28 +74,17 @@ let error_a_generative_module_expected l = "component of generative modules can be changed using the \"with\" " ^ "construct.") -let error_local_context lo = +let error_local_context lo = match lo with - None -> + None -> error ("The local context is not empty.") | (Some l) -> error ("The local context of the component "^ (string_of_label l)^" is not empty.") -let error_no_such_label_sub l l1 l2 = - error (l1^" is not a subtype of "^l2^".\nThe field "^(string_of_label l)^" is missing in "^l1^".") - - - -let rec list_split_assoc k rev_before = function - | [] -> raise Not_found - | (k',b)::after when k=k' -> rev_before,b,after - | h::tail -> list_split_assoc k (h::rev_before) tail - -let path_of_seb = function - | SEBident mp -> mp - | _ -> anomaly "Modops: evaluation failed." +let error_no_such_label_sub l l1 = + error ("The field "^(string_of_label l)^" is missing in "^l1^".") let destr_functor env mtb = @@ -104,123 +93,126 @@ let destr_functor env mtb = (arg_id,arg_t,body_t) | _ -> error_not_a_functor mtb -(* the constraints are not important here *) +let is_functor = function + | SEBfunctor (arg_id,arg_t,body_t) -> true + | _ -> false -let module_body_of_type mtb = - { mod_type = Some mtb.typ_expr; +let module_body_of_type mp mtb = + { mod_mp = mp; + mod_type = mtb.typ_expr; + mod_type_alg = mtb.typ_expr_alg; mod_expr = None; - mod_constraints = Constraint.empty; - mod_alias = mtb.typ_alias; + mod_constraints = mtb.typ_constraints; + mod_delta = mtb.typ_delta; mod_retroknowledge = []} -let module_type_of_module mp mb = - let mp1,expr = - (match mb.mod_type with - | Some expr -> mp,expr - | None -> (match mb.mod_expr with - | Some (SEBident mp') ->(Some mp'),(SEBident mp') - | Some expr -> mp,expr - | None -> - anomaly "Modops: empty expr and type")) in - {typ_expr = expr; - typ_alias = mb.mod_alias; - typ_strength = mp1 - } - -let rec check_modpath_equiv env mp1 mp2 = +let check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else - let mp1 = scrape_alias mp1 env in - let mp2 = scrape_alias mp2 env in - if mp1=mp2 then () - else - error_not_equal mp1 mp2 - + let mb1=lookup_module mp1 env in + let mb2=lookup_module mp2 env in + if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2) + then () + else error_not_equal mp1 mp2 + let rec subst_with_body sub = function - | With_module_body(id,mp,typ_opt,cst) -> - With_module_body(id,subst_mp sub mp,Option.smartmap - (subst_struct_expr sub) typ_opt,cst) + | With_module_body(id,mp) -> + With_module_body(id,subst_mp sub mp) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) -and subst_modtype sub mtb = - let typ_expr' = subst_struct_expr sub mtb.typ_expr in - let sub_mtb = join_alias mtb.typ_alias sub in - if typ_expr'==mtb.typ_expr && sub_mtb==mtb.typ_alias then - mtb +and subst_modtype sub do_delta mtb= + let mp = subst_mp sub mtb.typ_mp in + let sub = add_mp mtb.typ_mp mp empty_delta_resolver sub in + let typ_expr' = subst_struct_expr sub do_delta mtb.typ_expr in + let typ_alg' = + Option.smartmap + (subst_struct_expr sub (fun x -> x)) mtb.typ_expr_alg in + let mtb_delta = do_delta mtb.typ_delta in + if typ_expr'==mtb.typ_expr && + typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then + mtb else - { mtb with - typ_expr = typ_expr'; - typ_alias = sub_mtb} - -and subst_structure sub sign = - let subst_body = function - SFBconst cb -> + {mtb with + typ_mp = mp; + typ_expr = typ_expr'; + typ_expr_alg = typ_alg'; + typ_delta = mtb_delta} + +and subst_structure sub do_delta sign = + let subst_body = function + SFBconst cb -> SFBconst (subst_const_body sub cb) - | SFBmind mib -> + | SFBmind mib -> SFBmind (subst_mind sub mib) - | SFBmodule mb -> - SFBmodule (subst_module sub mb) - | SFBmodtype mtb -> - SFBmodtype (subst_modtype sub mtb) - | SFBalias (mp,typ_opt,cst) -> - SFBalias (subst_mp sub mp,Option.smartmap - (subst_struct_expr sub) typ_opt,cst) + | SFBmodule mb -> + SFBmodule (subst_module sub do_delta mb) + | SFBmodtype mtb -> + SFBmodtype (subst_modtype sub do_delta mtb) in List.map (fun (l,b) -> (l,subst_body b)) sign -and subst_module sub mb = - let mtb' = Option.smartmap (subst_struct_expr sub) mb.mod_type in - (* This is similar to the previous case. In this case we have - a module M in a signature that is knows to be equivalent to a module M' - (because the signature is "K with Module M := M'") and we are substituting - M' with some M''. *) - let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in - let mb_alias = update_subst sub mb.mod_alias in - let mb_alias = if mb_alias = empty_subst then - join_alias mb.mod_alias sub - else - join mb_alias (join_alias mb.mod_alias sub) - in - if mtb'==mb.mod_type && mb.mod_expr == me' - && mb_alias == mb.mod_alias +and subst_module sub do_delta mb = + let mp = subst_mp sub mb.mod_mp in + let sub = if is_functor mb.mod_type && not(mp=mb.mod_mp) then + add_mp mb.mod_mp mp + empty_delta_resolver sub else sub in + let id_delta = (fun x -> x) in + let mtb',me' = + let mtb = subst_struct_expr sub do_delta mb.mod_type in + match mb.mod_expr with + None -> mtb,None + | Some me -> if me==mb.mod_type then + mtb,Some mtb + else mtb,Option.smartmap + (subst_struct_expr sub id_delta) mb.mod_expr + in + let typ_alg' = Option.smartmap + (subst_struct_expr sub id_delta) mb.mod_type_alg in + let mb_delta = do_delta mb.mod_delta in + if mtb'==mb.mod_type && mb.mod_expr == me' + && mb_delta == mb.mod_delta && mp == mb.mod_mp then mb else - { mod_expr = me'; - mod_type=mtb'; - mod_constraints=mb.mod_constraints; - mod_alias = mb_alias; - mod_retroknowledge=mb.mod_retroknowledge} - - -and subst_struct_expr sub = function - | SEBident mp -> SEBident (subst_mp sub mp) - | SEBfunctor (msid, mtb, meb') -> - SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb') - | SEBstruct (msid,str)-> - SEBstruct(msid, subst_structure sub str) + { mb with + mod_mp = mp; + mod_expr = me'; + mod_type_alg = typ_alg'; + mod_type=mtb'; + mod_delta = mb_delta} + +and subst_struct_expr sub do_delta = function + | SEBident mp -> SEBident (subst_mp sub mp) + | SEBfunctor (mbid, mtb, meb') -> + SEBfunctor(mbid,subst_modtype sub do_delta mtb + ,subst_struct_expr sub do_delta meb') + | SEBstruct (str)-> + SEBstruct( subst_structure sub do_delta str) | SEBapply (meb1,meb2,cst)-> - SEBapply(subst_struct_expr sub meb1, - subst_struct_expr sub meb2, + SEBapply(subst_struct_expr sub do_delta meb1, + subst_struct_expr sub do_delta meb2, cst) - | SEBwith (meb,wdb)-> - SEBwith(subst_struct_expr sub meb, + | SEBwith (meb,wdb)-> + SEBwith(subst_struct_expr sub do_delta meb, subst_with_body sub wdb) +let subst_signature subst = + subst_structure subst + (fun resolver -> subst_codom_delta_resolver subst resolver) -let subst_signature_msid msid mp = - subst_structure (map_msid msid mp) +let subst_struct_expr subst = + subst_struct_expr subst + (fun resolver -> subst_codom_delta_resolver subst resolver) -(* spiwack: here comes the function which takes care of importing +(* spiwack: here comes the function which takes care of importing the retroknowledge declared in the library *) (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) -let add_retroknowledge msid mp = - let subst = add_msid msid mp empty_subst in - let subst_and_perform rkaction env = +let add_retroknowledge mp = + let perform rkaction env = match rkaction with | Retroknowledge.RKRegister (f, e) -> - Environ.register env f - (match e with - | Const kn -> kind_of_term (subst_mps subst (mkConst kn)) - | Ind ind -> kind_of_term (subst_mps subst (mkInd ind)) + Environ.register env f + (match e with + | Const kn -> kind_of_term (mkConst kn) + | Ind ind -> kind_of_term (mkInd ind) | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term") in fun lclrk env -> @@ -229,305 +221,283 @@ let add_retroknowledge msid mp = int31 type registration absolutely needs int31 bits to be registered. Since the local_retroknowledge is stored in reverse order (each new registration is added at the top of the list) we need a fold_right - for things to go right (the pun is not intented). So we lose + for things to go right (the pun is not intented). So we lose tail recursivity, but the world will have exploded before any module imports 10 000 retroknowledge registration.*) - List.fold_right subst_and_perform lclrk env + List.fold_right perform lclrk env +let rec add_signature mp sign resolver env = + let add_one env (l,elem) = + let kn = make_kn mp empty_dirpath l in + let con = constant_of_kn kn in + let mind = mind_of_kn kn in + match elem with + | SFBconst cb -> + let con = constant_of_delta resolver con in + Environ.add_constant con cb env + | SFBmind mib -> + let mind = mind_of_delta resolver mind in + Environ.add_mind mind mib env + | SFBmodule mb -> add_module mb env + (* adds components as well *) + | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env + in + List.fold_left add_one env sign +and add_module mb env = + let mp = mb.mod_mp in + let env = Environ.shallow_add_module mp mb env in + match mb.mod_type with + | SEBstruct (sign) -> + add_retroknowledge mp mb.mod_retroknowledge + (add_signature mp sign mb.mod_delta env) + | SEBfunctor _ -> env + | _ -> anomaly "Modops:the evaluation of the structure failed " -let strengthen_const env mp l cb = +let strengthen_const env mp_from l cb resolver = match cb.const_opaque, cb.const_body with | false, Some _ -> cb - | true, Some _ + | true, Some _ | _, None -> - let const = mkConst (make_con mp empty_dirpath l) in + let con = make_con mp_from empty_dirpath l in + let con = constant_of_delta resolver con in + let const = mkConst con in let const_subs = Some (Declarations.from_val const) in - {cb with + {cb with const_body = const_subs; const_opaque = false; const_body_code = Cemitcodes.from_val (compile_constant_body env const_subs false false) } - -let strengthen_mind env mp l mib = match mib.mind_equiv with - | Some _ -> mib - | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)} - - -let rec eval_struct env = function - | SEBident mp -> - begin - let mtb =lookup_modtype mp env in - match mtb.typ_expr,mtb.typ_strength with - mtb,None -> eval_struct env mtb - | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb) - end - | SEBapply (seb1,seb2,_) -> - let svb1 = eval_struct env seb1 in - let farg_id, farg_b, fbody_b = destr_functor env svb1 in - let mp = path_of_seb seb2 in - let mp = scrape_alias mp env in - let sub_alias = (lookup_modtype mp env).typ_alias in - let sub_alias = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> - join_alias - (subst_key (map_msid msid mp) sub_alias) - (map_msid msid mp) - | _ -> sub_alias in - let resolve = resolver_of_environment farg_id farg_b mp sub_alias env in - let sub_alias1 = update_subst sub_alias - (map_mbid farg_id mp (Some resolve)) in - eval_struct env (subst_struct_expr - (join sub_alias1 - (map_mbid farg_id mp (Some resolve))) fbody_b) - | SEBwith (mtb,(With_definition_body _ as wdb)) -> - let mtb',_ = merge_with env mtb wdb empty_subst in - mtb' - | SEBwith (mtb, (With_module_body (_,mp,_,_) as wdb)) -> - let alias_in_mp = - (lookup_modtype mp env).typ_alias in - let alias_in_mp = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> subst_key (map_msid msid mp) alias_in_mp - | _ -> alias_in_mp in - let mtb',_ = merge_with env mtb wdb alias_in_mp in - mtb' -(* | SEBfunctor(mbid,mtb,body) -> - let env = add_module (MPbound mbid) (module_body_of_type mtb) env in - SEBfunctor(mbid,mtb,eval_struct env body) *) - | mtb -> mtb - -and type_of_mb env mb = - match mb.mod_type,mb.mod_expr with - None,Some b -> eval_struct env b - | Some t, _ -> eval_struct env t - | _,_ -> anomaly - "Modops: empty type and empty expr" - -and merge_with env mtb with_decl alias= - let msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) -> msid,sig_b - | _ -> error_signature_expected mtb - in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl - | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false - in - let l = label_of_id id in - try - let rev_before,spec,after = list_split_assoc l [] sig_b in - let before = List.rev rev_before in - let rec mp_rec = function - | [] -> MPself msid - | i::r -> MPdot(mp_rec r,label_of_id i) - in - let env' = add_signature (MPself msid) before env in - let new_spec,subst = match with_decl with - | With_definition_body ([],_) - | With_module_body ([],_,_,_) -> assert false - | With_definition_body ([id],c) -> - SFBconst c,None - | With_module_body ([id], mp,typ_opt,cst) -> - let mp' = scrape_alias mp env' in - let new_alias = update_subst alias (map_mp (mp_rec [id]) mp') in - SFBalias (mp,typ_opt,Some cst), - Some(join (map_mp (mp_rec [id]) mp') new_alias) - | With_definition_body (_::_,_) - | With_module_body (_::_,_,_,_) -> - let old,aliasold = match spec with - SFBmodule msb -> Some msb, None - | SFBalias (mpold,typ_opt,cst) ->None, Some (mpold,typ_opt,cst) - | _ -> error_not_a_module (string_of_label l) - in - if aliasold = None then - let old = Option.get old in - let new_with_decl,subst1 = - match with_decl with - With_definition_body (_,c) -> With_definition_body (idl,c),None - | With_module_body (idc,mp,typ_opt,cst) -> - let mp' = scrape_alias mp env' in - With_module_body (idl,mp,typ_opt,cst), - Some(map_mp (mp_rec (List.rev idc)) mp') - in - let subst = match subst1 with - | None -> None - | Some s -> Some (join s (update_subst alias s)) in - let modtype,subst_msb = - merge_with env' (type_of_mb env' old) new_with_decl alias in - let msb = - { mod_expr = None; - mod_type = Some modtype; - mod_constraints = old.mod_constraints; - mod_alias = begin - match subst_msb with - |None -> empty_subst - |Some s -> s - end; - mod_retroknowledge = old.mod_retroknowledge} - in - (SFBmodule msb),subst + + +let rec strengthen_mod env mp_from mp_to mb = + assert(mp_from = mb.mod_mp); + if mp_in_delta mb.mod_mp mb.mod_delta then + mb + else + match mb.mod_type with + | SEBstruct (sign) -> + let resolve_out,sign_out = + strengthen_sig env mp_from sign mp_to mb.mod_delta in + { mb with + mod_expr = Some (SEBident mp_to); + mod_type = SEBstruct(sign_out); + mod_type_alg = mb.mod_type_alg; + mod_constraints = mb.mod_constraints; + mod_delta = add_mp_delta_resolver mp_from mp_to + (add_delta_resolver mb.mod_delta resolve_out); + mod_retroknowledge = mb.mod_retroknowledge} + | SEBfunctor _ -> mb + | _ -> anomaly "Modops:the evaluation of the structure failed " + +and strengthen_sig env mp_from sign mp_to resolver = + match sign with + | [] -> empty_delta_resolver,[] + | (l,SFBconst cb) :: rest -> + let item' = + l,SFBconst (strengthen_const env mp_from l cb resolver) in + let resolve_out,rest' = + strengthen_sig env mp_from rest mp_to resolver in + resolve_out,item'::rest' + | (_,SFBmind _ as item):: rest -> + let resolve_out,rest' = + strengthen_sig env mp_from rest mp_to resolver in + resolve_out,item::rest' + | (l,SFBmodule mb) :: rest -> + let mp_from' = MPdot (mp_from,l) in + let mp_to' = MPdot(mp_to,l) in + let mb_out = + strengthen_mod env mp_from' mp_to' mb in + let item' = l,SFBmodule (mb_out) in + let env' = add_module mb_out env in + let resolve_out,rest' = + strengthen_sig env' mp_from rest mp_to resolver in + add_delta_resolver resolve_out mb.mod_delta, + item':: rest' + | (l,SFBmodtype mty as item) :: rest -> + let env' = add_modtype + (MPdot(mp_from,l)) mty env + in + let resolve_out,rest' = + strengthen_sig env' mp_from rest mp_to resolver in + resolve_out,item::rest' + +let strengthen env mtb mp = + if mp_in_delta mtb.typ_mp mtb.typ_delta then + (* in this case mtb has already been strengthened*) + mtb + else + match mtb.typ_expr with + | SEBstruct (sign) -> + let resolve_out,sign_out = + strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in + {mtb with + typ_expr = SEBstruct(sign_out); + typ_delta = add_delta_resolver mtb.typ_delta + (add_mp_delta_resolver mtb.typ_mp mp resolve_out)} + | SEBfunctor _ -> mtb + | _ -> anomaly "Modops:the evaluation of the structure failed " + +let module_type_of_module env mp mb = + match mp with + Some mp -> + strengthen env { + typ_mp = mp; + typ_expr = mb.mod_type; + typ_expr_alg = None; + typ_constraints = mb.mod_constraints; + typ_delta = mb.mod_delta} mp + + | None -> + {typ_mp = mb.mod_mp; + typ_expr = mb.mod_type; + typ_expr_alg = None; + typ_constraints = mb.mod_constraints; + typ_delta = mb.mod_delta} + +let complete_inline_delta_resolver env mp mbid mtb delta = + let constants = inline_of_delta mtb.typ_delta in + let rec make_inline delta = function + | [] -> delta + | kn::r -> + let kn = replace_mp_in_kn (MPbound mbid) mp kn in + let con = constant_of_kn kn in + let con' = constant_of_delta delta con in + let constant = lookup_constant con' env in + if (not constant.Declarations.const_opaque) then + let constr = Option.map Declarations.force + constant.Declarations.const_body in + if constr = None then + (make_inline delta r) else - let mpold,typ_opt,cst = Option.get aliasold in - SFBalias (mpold,typ_opt,cst),None - in - SEBstruct(msid, before@(l,new_spec):: - (Option.fold_right subst_structure subst after)),subst - with - Not_found -> error_no_such_label l - -and add_signature mp sign env = - let add_one env (l,elem) = - let kn = make_kn mp empty_dirpath l in - let con = make_con mp empty_dirpath l in - match elem with - | SFBconst cb -> Environ.add_constant con cb env - | SFBmind mib -> Environ.add_mind kn mib env - | SFBmodule mb -> - add_module (MPdot (mp,l)) mb env - (* adds components as well *) - | SFBalias (mp1,_,cst) -> - Environ.register_alias (MPdot(mp,l)) mp1 env - | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) - mtb env + add_inline_constr_delta_resolver con (Option.get constr) + (make_inline delta r) + else + (make_inline delta r) in - List.fold_left add_one env sign - -and add_module mp mb env = - let env = Environ.shallow_add_module mp mb env in - let env = - Environ.add_modtype mp (module_type_of_module (Some mp) mb) env - in - let mod_typ = type_of_mb env mb in - match mod_typ with - | SEBstruct (msid,sign) -> - add_retroknowledge msid mp (mb.mod_retroknowledge) - (add_signature mp (subst_signature_msid msid mp sign) env) - | SEBfunctor _ -> env - | _ -> anomaly "Modops:the evaluation of the structure failed " - - - -and constants_of_specification env mp sign = - let aux (env,res) (l,elem) = - match elem with - | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res - | SFBmind _ -> env,res - | SFBmodule mb -> - let new_env = add_module (MPdot (mp,l)) mb env in - new_env,(constants_of_modtype env (MPdot (mp,l)) - (type_of_mb env mb)) @ res - | SFBalias (mp1,typ_opt,cst) -> - let new_env = register_alias (MPdot (mp,l)) mp1 env in - new_env,(constants_of_modtype env (MPdot (mp,l)) - (eval_struct env (SEBident mp1))) @ res - | SFBmodtype mtb -> - (* module type dans un module type. - Il faut au moins mettre mtb dans l'environnement (avec le bon - kn pour pouvoir continuer aller deplier les modules utilisant ce - mtb - ex: - Module Type T1. - Module Type T2. - .... - End T2. - ..... - Declare Module M : T2. - End T2 - si on ne rajoute pas T2 dans l'environement de typage - on va exploser au moment du Declare Module - *) - let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in - new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res - in - snd (List.fold_left aux (env,[]) sign) - -and constants_of_modtype env mp modtype = - match (eval_struct env modtype) with - SEBstruct (msid,sign) -> - constants_of_specification env mp - (subst_signature_msid msid mp sign) - | SEBfunctor _ -> [] - | _ -> anomaly "Modops:the evaluation of the structure failed " - -(* returns a resolver for kn that maps mbid to mp. We only keep - constants that have the inline flag *) -and resolver_of_environment mbid modtype mp alias env = - let constants = constants_of_modtype env (MPbound mbid) modtype.typ_expr in - let constants = List.map (fun (l,cb) -> (l,subst_const_body alias cb)) constants in - let rec make_resolve = function - | [] -> [] - | (con,expecteddef)::r -> - let con' = replace_mp_in_con (MPbound mbid) mp con in - let con',_ = subst_con alias con' in - (* let con' = replace_mp_in_con (MPbound mbid) mp con' in *) - try - if expecteddef.Declarations.const_inline then - let constant = lookup_constant con' env in - if (not constant.Declarations.const_opaque) then - let constr = Option.map Declarations.force - constant.Declarations.const_body in - (con,constr)::(make_resolve r) - else make_resolve r - else make_resolve r - with Not_found -> error_no_such_label (con_label con') - in - let resolve = make_resolve constants in - Mod_subst.make_resolver resolve - - -and strengthen_mtb env mp mtb = - let mtb1 = eval_struct env mtb in - match mtb1 with - | SEBfunctor _ -> mtb1 - | SEBstruct (msid,sign) -> - SEBstruct (msid,strengthen_sig env msid sign mp) - | _ -> anomaly "Modops:the evaluation of the structure failed " - -and strengthen_mod env mp mb = - let mod_typ = type_of_mb env mb in - { mod_expr = mb.mod_expr; - mod_type = Some (strengthen_mtb env mp mod_typ); - mod_constraints = mb.mod_constraints; - mod_alias = mb.mod_alias; - mod_retroknowledge = mb.mod_retroknowledge} - -and strengthen_sig env msid sign mp = match sign with - | [] -> [] - | (l,SFBconst cb) :: rest -> - let item' = l,SFBconst (strengthen_const env mp l cb) in - let rest' = strengthen_sig env msid rest mp in + make_inline delta constants + +let rec strengthen_and_subst_mod + mb subst env mp_from mp_to env resolver = + match mb.mod_type with + SEBstruct(str) -> + let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in + if mb_is_an_alias then + subst_module subst + (fun resolver -> subst_dom_delta_resolver subst resolver) mb + else + let resolver,new_sig = + strengthen_and_subst_struct str subst env + mp_from mp_from mp_to false false mb.mod_delta + in + {mb with + mod_mp = mp_to; + mod_expr = Some (SEBident mp_from); + mod_type = SEBstruct(new_sig); + mod_delta = add_mp_delta_resolver mp_to mp_from resolver} + | SEBfunctor(arg_id,arg_b,body) -> + subst_module subst + (fun resolver -> subst_dom_delta_resolver subst resolver) mb + | _ -> anomaly "Modops:the evaluation of the structure failed " + +and strengthen_and_subst_struct + str subst env mp_alias mp_from mp_to alias incl resolver = + match str with + | [] -> empty_delta_resolver,[] + | (l,SFBconst cb) :: rest -> + let item' = if alias then + l,SFBconst (subst_const_body subst cb) + else + l,SFBconst (strengthen_const env mp_from l + (subst_const_body subst cb) resolver) + in + let con = make_con mp_from empty_dirpath l in + let resolve_out,rest' = + strengthen_and_subst_struct rest subst env + mp_alias mp_from mp_to alias incl resolver in + if incl && not (con_in_delta con resolver) then + (add_constant_delta_resolver + (make_con_equiv mp_to mp_alias empty_dirpath l) resolve_out), item'::rest' - | (l,SFBmind mib) :: rest -> - let item' = l,SFBmind (strengthen_mind env mp l mib) in - let rest' = strengthen_sig env msid rest mp in + else + resolve_out,item'::rest' + | (l,SFBmind mib) :: rest -> + let item' = l,SFBmind (subst_mind subst mib) in + let mind = make_mind mp_from empty_dirpath l in + let resolve_out,rest' = + strengthen_and_subst_struct rest subst env + mp_alias mp_from mp_to alias incl resolver in + if incl && not (mind_in_delta mind resolver) then + (add_mind_delta_resolver + (make_mind_equiv mp_to mp_alias empty_dirpath l) resolve_out), item'::rest' - | (l,SFBmodule mb) :: rest -> - let mp' = MPdot (mp,l) in - let item' = l,SFBmodule (strengthen_mod env mp' mb) in - let env' = add_module - (MPdot (MPself msid,l)) mb env in - let rest' = strengthen_sig env' msid rest mp in + else + resolve_out,item'::rest' + | (l,SFBmodule mb) :: rest -> + let mp_from' = MPdot (mp_from,l) in + let mp_to' = MPdot(mp_to,l) in + let mb_out = if alias then + subst_module subst + (fun resolver -> subst_dom_delta_resolver subst resolver) mb + else + strengthen_and_subst_mod + mb subst env mp_from' mp_to' env resolver + in + let item' = l,SFBmodule (mb_out) in + let env' = add_module mb_out env in + let resolve_out,rest' = + strengthen_and_subst_struct rest subst env' + mp_alias mp_from mp_to alias incl resolver in + add_delta_resolver resolve_out mb_out.mod_delta, item':: rest' - | ((l,SFBalias (mp1,_,cst)) as item) :: rest -> - let env' = register_alias (MPdot(MPself msid,l)) mp1 env in - let rest' = strengthen_sig env' msid rest mp in - item::rest' - | (l,SFBmodtype mty as item) :: rest -> - let env' = add_modtype - (MPdot((MPself msid),l)) - mty - env - in - let rest' = strengthen_sig env' msid rest mp in - item::rest' - - -let strengthen env mtb mp = strengthen_mtb env mp mtb - - -let update_subst env mb mp = - match type_of_mb env mb with - | SEBstruct(msid,str) -> false, join_alias - (subst_key (map_msid msid mp) mb.mod_alias) - (map_msid msid mp) - | _ -> true, mb.mod_alias + | (l,SFBmodtype mty) :: rest -> + let mp_from' = MPdot (mp_from,l) in + let mp_to' = MPdot(mp_to,l) in + let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in + let mty = subst_modtype subst' + (fun resolver -> subst_dom_codom_delta_resolver subst' resolver) mty in + let env' = add_modtype mp_from' mty env in + let resolve_out,rest' = strengthen_and_subst_struct rest subst env' + mp_alias mp_from mp_to alias incl resolver in + (add_mp_delta_resolver + mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest' + +let strengthen_and_subst_mb mb mp env include_b = + match mb.mod_type with + SEBstruct str -> + let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in + (*if mb is an alias then the strengthening is useless + (i.e. it is already done)*) + let mp_alias = delta_of_mp mb.mod_delta mb.mod_mp in + let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in + let resolver = + add_mp_delta_resolver mp mp_alias + (subst_dom_delta_resolver subst_resolver mb.mod_delta) in + let subst = map_mp mb.mod_mp mp resolver in + let resolver = if mb_is_an_alias && include_b then + remove_mp_delta_resolver mb.mod_delta mb.mod_mp + else mb.mod_delta in + let resolver,new_sig = + strengthen_and_subst_struct str subst env + mp_alias mb.mod_mp mp mb_is_an_alias include_b resolver + in + {mb with + mod_mp = mp; + mod_type = SEBstruct(new_sig); + mod_expr = Some (SEBident mb.mod_mp); + mod_delta = if include_b then resolver + else add_mp_delta_resolver mp mp_alias resolver} + | SEBfunctor(arg_id,argb,body) -> + let subst = map_mp mb.mod_mp mp empty_delta_resolver in + subst_module subst + (fun resolver -> subst_dom_codom_delta_resolver subst resolver) mb + | _ -> anomaly "Modops:the evaluation of the structure failed " + + +let subst_modtype_and_resolver mtb mp env = + let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in + let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in + let full_subst = (map_mp mtb.typ_mp mp new_delta) in + subst_modtype full_subst + (fun resolver -> subst_dom_codom_delta_resolver subst resolver) mtb diff --git a/kernel/modops.mli b/kernel/modops.mli index 4cd72a2ef..44d29ee3e 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -20,46 +20,38 @@ open Mod_subst (* Various operations on modules and module types *) -(* make the environment entry out of type *) -val module_body_of_type : module_type_body -> module_body -val module_type_of_module : module_path option -> module_body -> +val module_body_of_type : module_path -> module_type_body -> module_body + +val module_type_of_module : env -> module_path option -> module_body -> module_type_body val destr_functor : env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body -val subst_modtype : substitution -> module_type_body -> module_type_body -val subst_structure : substitution -> structure_body -> structure_body - val subst_struct_expr : substitution -> struct_expr_body -> struct_expr_body -val subst_signature_msid : - mod_self_id -> module_path -> - structure_body -> structure_body - -val subst_structure : substitution -> structure_body -> structure_body - -(* Evaluation functions *) -val eval_struct : env -> struct_expr_body -> struct_expr_body - -val type_of_mb : env -> module_body -> struct_expr_body +val subst_signature : substitution -> structure_body -> structure_body -(* [add_signature mp sign env] assumes that the substitution [msid] - $\mapsto$ [mp] has already been performed (or is not necessary, like - when [mp = MPself msid]) *) val add_signature : - module_path -> structure_body -> env -> env + module_path -> structure_body -> delta_resolver -> env -> env (* adds a module and its components, but not the constraints *) -val add_module : - module_path -> module_body -> env -> env +val add_module : module_body -> env -> env val check_modpath_equiv : env -> module_path -> module_path -> unit -val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body +val strengthen : env -> module_type_body -> module_path -> module_type_body -val update_subst : env -> module_body -> module_path -> bool * substitution +val complete_inline_delta_resolver : + env -> module_path -> mod_bound_id -> module_type_body -> + delta_resolver -> delta_resolver + +val strengthen_and_subst_mb : module_body -> module_path -> env -> bool + -> module_body + +val subst_modtype_and_resolver : module_type_body -> module_path -> env -> + module_type_body val error_existing_label : label -> 'a @@ -102,9 +94,7 @@ val error_a_generative_module_expected : label -> 'a val error_local_context : label option -> 'a -val error_no_such_label_sub : label->string->string->'a +val error_no_such_label_sub : label->string->'a + -val resolver_of_environment : - mod_bound_id -> module_type_body -> module_path -> substitution - -> env -> resolver diff --git a/kernel/names.ml b/kernel/names.ml index 0d61a29aa..06ca87b4d 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -108,7 +108,7 @@ module Labmap = Idmap type module_path = | MPfile of dir_path | MPbound of mod_bound_id - | MPself of mod_self_id + (* | MPapp of module_path * module_path *) | MPdot of module_path * label let rec check_bound_mp = function @@ -119,7 +119,9 @@ let rec check_bound_mp = function let rec string_of_mp = function | MPfile sl -> "MPfile (" ^ string_of_dirpath sl ^ ")" | MPbound uid -> string_of_uid uid - | MPself uid -> string_of_uid uid + (* | MPapp (mp1,mp2) -> + "("^string_of_mp mp ^ " " ^ + string_of_mp mp^")"*) | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l (* we compare labels first if both are MPdots *) @@ -172,6 +174,28 @@ let kn_ord kn1 kn2 = else MPord.compare mp1 mp2 +(* a constant name is a kernel name couple (kn1,kn2) + where kn1 corresponds to the name used at toplevel + (i.e. what the user see) + and kn2 corresponds to the canonical kernel name + i.e. in the environment we have + kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *) +type constant = kernel_name*kernel_name + +(* For the environment we distinguish constants by their + user part*) +module User_ord = struct + type t = kernel_name*kernel_name + let compare x y= kn_ord (fst x) (fst y) +end + +(* For other uses (ex: non-logical things) it is enough + to deal with the canonical part *) +module Canonical_ord = struct + type t = kernel_name*kernel_name + let compare x y= kn_ord (snd x) (snd y) +end + module KNord = struct type t = kernel_name @@ -181,47 +205,89 @@ end module KNmap = Map.Make(KNord) module KNpred = Predicate.Make(KNord) module KNset = Set.Make(KNord) -module Cmap = KNmap -module Cpred = KNpred -module Cset = KNset + +module Cmap = Map.Make(Canonical_ord) +module Cmap_env = Map.Make(User_ord) +module Cpred = Predicate.Make(Canonical_ord) +module Cset = Set.Make(Canonical_ord) +module Cset_env = Set.Make(User_ord) + +module Mindmap = Map.Make(Canonical_ord) +module Mindset = Set.Make(Canonical_ord) +module Mindmap_env = Map.Make(User_ord) let default_module_name = "If you see this, it's a bug" let initial_dir = make_dirpath [default_module_name] let initial_msid = (make_msid initial_dir "If you see this, it's a bug") -let initial_path = MPself initial_msid +let initial_path = MPfile initial_dir type variable = identifier -type constant = kernel_name -type mutual_inductive = kernel_name + +(* The same thing is done for mutual inductive names + it replaces also the old mind_equiv field of mutual + inductive types*) +type mutual_inductive = kernel_name*kernel_name type inductive = mutual_inductive * int type constructor = inductive * int -let constant_of_kn kn = kn -let make_con mp dir l = (mp,dir,l) -let repr_con con = con -let string_of_con = string_of_kn -let con_label = label -let pr_con = pr_kn -let con_modpath = modpath - -let mind_modpath = modpath +let constant_of_kn kn = (kn,kn) +let constant_of_kn_equiv kn1 kn2 = (kn1,kn2) +let make_con mp dir l = ((mp,dir,l),(mp,dir,l)) +let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) +let canonical_con con = snd con +let user_con con = fst con +let repr_con con = fst con +let string_of_con con = string_of_kn (fst con) +let con_label con = label (fst con) +let pr_con con = pr_kn (fst con) +let debug_pr_con con = str "("++ pr_kn (fst con) ++ str ","++ pr_kn (snd con)++ str ")" +let eq_constant (_,kn1) (_,kn2) = kn1=kn2 +let debug_string_of_con con = string_of_kn (fst con)^"'"^string_of_kn (snd con) + +let con_modpath con = modpath (fst con) + +let mind_modpath mind = modpath (fst mind) let ind_modpath ind = mind_modpath (fst ind) let constr_modpath c = ind_modpath (fst c) + +let mind_of_kn kn = (kn,kn) +let mind_of_kn_equiv kn1 kn2 = (kn1,kn2) +let make_mind mp dir l = ((mp,dir,l),(mp,dir,l)) +let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) +let canonical_mind mind = snd mind +let user_mind mind = fst mind +let repr_mind mind = fst mind +let string_of_mind mind = string_of_kn (fst mind) +let mind_label mind= label (fst mind) +let pr_mind mind = pr_kn (fst mind) +let debug_pr_mind mind = str "("++ pr_kn (fst mind) ++ str ","++ pr_kn (snd mind)++ str ")" +let eq_mind (_,kn1) (_,kn2) = kn1=kn2 +let debug_string_of_mind mind = string_of_kn (fst mind)^"'"^string_of_kn (snd mind) + let ith_mutual_inductive (kn,_) i = (kn,i) let ith_constructor_of_inductive ind i = (ind,i) let inductive_of_constructor (ind,i) = ind let index_of_constructor (ind,i) = i +let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2 +let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2 module InductiveOrdered = struct type t = inductive let compare (spx,ix) (spy,iy) = - let c = ix - iy in if c = 0 then KNord.compare spx spy else c + let c = ix - iy in if c = 0 then Canonical_ord.compare spx spy else c +end + +module InductiveOrdered_env = struct + type t = inductive + let compare (spx,ix) (spy,iy) = + let c = ix - iy in if c = 0 then User_ord.compare spx spy else c end module Indmap = Map.Make(InductiveOrdered) +module Indmap_env = Map.Make(InductiveOrdered_env) module ConstructorOrdered = struct type t = constructor @@ -229,13 +295,24 @@ module ConstructorOrdered = struct let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c end +module ConstructorOrdered_env = struct + type t = constructor + let compare (indx,ix) (indy,iy) = + let c = ix - iy in if c = 0 then InductiveOrdered_env.compare indx indy else c +end + module Constrmap = Map.Make(ConstructorOrdered) +module Constrmap_env = Map.Make(ConstructorOrdered_env) (* Better to have it here that in closure, since used in grammar.cma *) type evaluable_global_reference = | EvalVarRef of identifier | EvalConstRef of constant +let eq_egr e1 e2 = match e1,e2 with + EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2 + | _,_ -> e1 = e2 + (* Hash-consing of name objects *) module Hname = Hashcons.Make( struct @@ -281,24 +358,24 @@ module Hmod = Hashcons.Make( let rec hash_sub (hdir,huniqid,hstr as hfuns) = function | MPfile dir -> MPfile (hdir dir) | MPbound m -> MPbound (huniqid m) - | MPself m -> MPself (huniqid m) | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l) let rec equal d1 d2 = match (d1,d2) with | MPfile dir1, MPfile dir2 -> dir1 == dir2 | MPbound m1, MPbound m2 -> m1 == m2 - | MPself m1, MPself m2 -> m1 == m2 | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2 | _ -> false let hash = Hashtbl.hash end) -module Hkn = Hashcons.Make( - struct - type t = kernel_name + +module Hcn = Hashcons.Make( + struct + type t = kernel_name*kernel_name type u = (module_path -> module_path) * (dir_path -> dir_path) * (string -> string) - let hash_sub (hmod,hdir,hstr) (md,dir,l) = (hmod md, hdir dir, hstr l) - let equal (mod1,dir1,l1) (mod2,dir2,l2) = + let hash_sub (hmod,hdir,hstr) ((md,dir,l),(mde,dire,le)) = + ((hmod md, hdir dir, hstr l),(hmod mde, hdir dire, hstr le)) + let equal ((mod1,dir1,l1),_) ((mod2,dir2,l2),_) = mod1 == mod2 && dir1 == dir2 && l1 == l2 let hash = Hashtbl.hash end) @@ -310,8 +387,9 @@ let hcons_names () = let hdir = Hashcons.simple_hcons Hdir.f hident in let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in - let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in - (hkn,hkn,hdir,hname,hident,hstring) + let hmind = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in + let hcn = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in + (hcn,hmind,hdir,hname,hident,hstring) (*******) @@ -335,3 +413,8 @@ type inv_rel_key = int (* index in the [rel_context] part of environment type id_key = inv_rel_key tableKey +let eq_id_key ik1 ik2 = + match ik1,ik2 with + ConstKey (_,kn1), + ConstKey (_,kn2) -> kn1=kn2 + | a,b -> a=b diff --git a/kernel/names.mli b/kernel/names.mli index fb3b5c81b..e42f8ea71 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -80,9 +80,9 @@ module Labmap : Map.S with type key = label type module_path = | MPfile of dir_path | MPbound of mod_bound_id - | MPself of mod_self_id + (* | MPapp of module_path * module_path very soon *) | MPdot of module_path * label -(*i | MPapply of module_path * module_path in the future (maybe) i*) + val check_bound_mp : module_path -> bool @@ -122,25 +122,64 @@ module KNmap : Map.S with type key = kernel_name type variable = identifier type constant -type mutual_inductive = kernel_name +type mutual_inductive (* Beware: first inductive has index 0 *) type inductive = mutual_inductive * int (* Beware: first constructor has index 1 *) type constructor = inductive * int +(* *_env modules consider an order on user part of names + the others consider an order on canonical part of names*) module Cmap : Map.S with type key = constant +module Cmap_env : Map.S with type key = constant module Cpred : Predicate.S with type elt = constant module Cset : Set.S with type elt = constant +module Cset_env : Set.S with type elt = constant +module Mindmap : Map.S with type key = mutual_inductive +module Mindmap_env : Map.S with type key = mutual_inductive +module Mindset : Set.S with type elt = mutual_inductive module Indmap : Map.S with type key = inductive module Constrmap : Map.S with type key = constructor +module Indmap_env : Map.S with type key = inductive +module Constrmap_env : Map.S with type key = constructor val constant_of_kn : kernel_name -> constant +val constant_of_kn_equiv : kernel_name -> kernel_name -> constant val make_con : module_path -> dir_path -> label -> constant +val make_con_equiv : module_path -> module_path -> dir_path + -> label -> constant +val user_con : constant -> kernel_name +val canonical_con : constant -> kernel_name val repr_con : constant -> module_path * dir_path * label +val eq_constant : constant -> constant -> bool + val string_of_con : constant -> string val con_label : constant -> label val con_modpath : constant -> module_path val pr_con : constant -> Pp.std_ppcmds +val debug_pr_con : constant -> Pp.std_ppcmds +val debug_string_of_con : constant -> string + + + +val mind_of_kn : kernel_name -> mutual_inductive +val mind_of_kn_equiv : kernel_name -> kernel_name -> mutual_inductive +val make_mind : module_path -> dir_path -> label -> mutual_inductive +val make_mind_equiv : module_path -> module_path -> dir_path + -> label -> mutual_inductive +val user_mind : mutual_inductive -> kernel_name +val canonical_mind : mutual_inductive -> kernel_name +val repr_mind : mutual_inductive -> module_path * dir_path * label +val eq_mind : mutual_inductive -> mutual_inductive -> bool + +val string_of_mind : mutual_inductive -> string +val mind_label : mutual_inductive -> label +val mind_modpath : mutual_inductive -> module_path +val pr_mind : mutual_inductive -> Pp.std_ppcmds +val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds +val debug_string_of_mind : mutual_inductive -> string + + val mind_modpath : mutual_inductive -> module_path val ind_modpath : inductive -> module_path @@ -150,16 +189,21 @@ val ith_mutual_inductive : inductive -> int -> inductive val ith_constructor_of_inductive : inductive -> int -> constructor val inductive_of_constructor : constructor -> inductive val index_of_constructor : constructor -> int +val eq_ind : inductive -> inductive -> bool +val eq_constructor : constructor -> constructor -> bool (* Better to have it here that in Closure, since required in grammar.cma *) type evaluable_global_reference = | EvalVarRef of identifier | EvalConstRef of constant +val eq_egr : evaluable_global_reference -> evaluable_global_reference + -> bool + (* Hash-consing *) val hcons_names : unit -> (constant -> constant) * - (kernel_name -> kernel_name) * (dir_path -> dir_path) * + (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) * (name -> name) * (identifier -> identifier) * (string -> string) @@ -182,3 +226,5 @@ type inv_rel_key = int (* index in the [rel_context] part of environment of de Bruijn indice *) type id_key = inv_rel_key tableKey + +val eq_id_key : id_key -> id_key -> bool diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 421672201..b58951e98 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -23,11 +23,10 @@ type key = int option ref type constant_key = constant_body * key type globals = { - env_constants : constant_key Cmap.t; - env_inductives : mutual_inductive_body KNmap.t; + env_constants : constant_key Cmap_env.t; + env_inductives : mutual_inductive_body Mindmap_env.t; env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t; - env_alias : module_path MPmap.t } + env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : universes; @@ -58,11 +57,10 @@ let empty_named_context_val = [],[] let empty_env = { env_globals = { - env_constants = Cmap.empty; - env_inductives = KNmap.empty; + env_constants = Cmap_env.empty; + env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; - env_modtypes = MPmap.empty; - env_alias = MPmap.empty }; + env_modtypes = MPmap.empty}; env_named_context = empty_named_context; env_named_vals = []; env_rel_context = empty_rel_context; @@ -123,16 +121,12 @@ let env_of_named id env = env (* Global constants *) let lookup_constant_key kn env = - Cmap.find kn env.env_globals.env_constants + Cmap_env.find kn env.env_globals.env_constants let lookup_constant kn env = - fst (Cmap.find kn env.env_globals.env_constants) + fst (Cmap_env.find kn env.env_globals.env_constants) (* Mutual Inductives *) let lookup_mind kn env = - KNmap.find kn env.env_globals.env_inductives + Mindmap_env.find kn env.env_globals.env_inductives -let rec scrape_mind env kn = - match (lookup_mind kn env).mind_equiv with - | None -> kn - | Some kn' -> scrape_mind env kn' diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index abbf9b1b5..718132b32 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -23,11 +23,10 @@ type key = int option ref type constant_key = constant_body * key type globals = { - env_constants : constant_key Cmap.t; - env_inductives : mutual_inductive_body KNmap.t; + env_constants : constant_key Cmap_env.t; + env_inductives : mutual_inductive_body Mindmap_env.t; env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t; - env_alias : module_path MPmap.t } + env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : universes; @@ -80,5 +79,3 @@ val lookup_constant : constant -> env -> constant_body (* Mutual Inductives *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body -(* Find the ultimate inductive in the [mind_equiv] chain *) -val scrape_mind : env -> mutual_inductive -> mutual_inductive diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 0a404fff3..92386c4d3 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -274,7 +274,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) - if fl1 = fl2 + if eq_table_key fl1 fl2 then convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible with NotConvertible -> @@ -325,13 +325,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd ind1, FInd ind2) -> - if mind_equiv_infos (snd infos) ind1 ind2 + if eq_ind ind1 ind2 then convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> - if j1 = j2 && mind_equiv_infos (snd infos) ind1 ind2 + if j1 = j2 && eq_ind ind1 ind2 then convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible @@ -377,7 +377,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = and convert_stacks infos lft1 lft2 stk1 stk2 cuniv = compare_stacks (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c) - (mind_equiv_infos (snd infos)) + (eq_ind) lft1 stk1 lft2 stk2 cuniv and convert_vect infos lft1 lft2 v1 v2 cuniv = diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index e73689bc8..b0dc6dd8a 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -35,13 +35,12 @@ type modvariant = | LIBRARY of dir_path type module_info = - { msid : mod_self_id; - modpath : module_path; - seed : dir_path; (* the "seed" of unique identifier generator *) - label : label; - variant : modvariant; - alias_subst : substitution} - + {modpath : module_path; + label : label; + variant : modvariant; + resolver : delta_resolver; + resolver_of_param : delta_resolver;} + let check_label l labset = if Labset.mem l labset then error_existing_label l @@ -80,12 +79,11 @@ let rec empty_environment = { old = empty_environment; env = empty_env; modinfo = { - msid = initial_msid; modpath = initial_path; - seed = initial_dir; label = mk_label "_"; variant = NONE; - alias_subst = empty_subst}; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver}; labset = Labset.empty; revstruct = []; univ = Univ.Constraint.empty; @@ -215,9 +213,16 @@ let add_constant dir l decl senv = in let senv' = add_constraints cb.const_constraints senv in let env'' = Environ.add_constant kn cb senv'.env in + let resolver = + if cb.const_inline then + add_inline_delta_resolver kn senv'.modinfo.resolver + else + senv'.modinfo.resolver + in kn, { old = senv'.old; env = env''; - modinfo = senv'.modinfo; + modinfo = {senv'.modinfo with + resolver = resolver}; labset = Labset.add l senv'.labset; revstruct = (l,SFBconst cb)::senv'.revstruct; univ = senv'.univ; @@ -242,7 +247,7 @@ let add_mind dir l mie senv = all labels *) let mib = translate_mind senv.env mie in let senv' = add_constraints mib.mind_constraints senv in - let kn = make_kn senv.modinfo.modpath dir l in + let kn = make_mind senv.modinfo.modpath dir l in let env'' = Environ.add_mind kn mib senv'.env in kn, { old = senv'.old; env = env''; @@ -259,118 +264,82 @@ let add_mind dir l mie senv = let add_modtype l mte senv = check_label l senv.labset; - let mtb_expr,sub = translate_struct_entry senv.env mte in - let mtb = { typ_expr = mtb_expr; - typ_strength = None; - typ_alias = sub} in - let senv' = add_constraints - (struct_expr_constraints mtb_expr) senv in let mp = MPdot(senv.modinfo.modpath, l) in - let env'' = Environ.add_modtype mp mtb senv'.env in - mp, { old = senv'.old; - env = env''; - modinfo = senv'.modinfo; - labset = Labset.add l senv'.labset; - revstruct = (l,SFBmodtype mtb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } + let mtb = translate_module_type senv.env mp mte in + let senv' = add_constraints mtb.typ_constraints senv in + let env'' = Environ.add_modtype mp mtb senv'.env in + mp, { old = senv'.old; + env = env''; + modinfo = senv'.modinfo; + labset = Labset.add l senv'.labset; + revstruct = (l,SFBmodtype mtb)::senv'.revstruct; + univ = senv'.univ; + engagement = senv'.engagement; + imports = senv'.imports; + loads = senv'.loads; + local_retroknowledge = senv'.local_retroknowledge } (* full_add_module adds module with universes and constraints *) -let full_add_module mp mb senv = - let senv = add_constraints (module_constraints mb) senv in - let env = Modops.add_module mp mb senv.env in +let full_add_module mb senv = + let senv = add_constraints mb.mod_constraints senv in + let env = Modops.add_module mb senv.env in {senv with env = env} (* Insertion of modules *) let add_module l me senv = check_label l senv.labset; - let mb = translate_module senv.env me in let mp = MPdot(senv.modinfo.modpath, l) in - let senv' = full_add_module mp mb senv in - let is_functor,sub = Modops.update_subst senv'.env mb mp in - mp, { old = senv'.old; - env = senv'.env; - modinfo = - if is_functor then - senv'.modinfo - else - {senv'.modinfo with - alias_subst = join senv'.modinfo.alias_subst sub}; - labset = Labset.add l senv'.labset; - revstruct = (l,SFBmodule mb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } - -let add_alias l mp senv = - check_label l senv.labset; - let mp' = MPdot(senv.modinfo.modpath, l) in - let mp1 = scrape_alias mp senv.env in - let typ_opt = - if check_bound_mp mp then - Some (strengthen senv.env - (lookup_modtype mp senv.env).typ_expr mp) - else - None + let mb = translate_module senv.env mp me in + let senv' = full_add_module mb senv in + let modinfo = match mb.mod_type with + SEBstruct _ -> + { senv'.modinfo with + resolver = + add_delta_resolver mb.mod_delta senv'.modinfo.resolver} + | _ -> senv'.modinfo in - (* we get all updated alias substitution {mp1.K\M} that comes from mp1 *) - let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in - (* transformation of {mp1.K\M} to {mp.K\M}*) - let sub = update_subst sub (map_mp mp' mp1) in - (* transformation of {mp.K\M} to {mp.K\M'} where M'=M{mp1\mp'}*) - let sub = join_alias sub (map_mp mp' mp1) in - (* we add the alias substitution *) - let sub = add_mp mp' mp1 sub in - let env' = register_alias mp' mp senv.env in - mp', { old = senv.old; - env = env'; - modinfo = { senv.modinfo with - alias_subst = join - senv.modinfo.alias_subst sub}; - labset = Labset.add l senv.labset; - revstruct = (l,SFBalias (mp,typ_opt,None))::senv.revstruct; - univ = senv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = senv.loads; - local_retroknowledge = senv.local_retroknowledge } - + mp,mb.mod_delta, + { old = senv'.old; + env = senv'.env; + modinfo = modinfo; + labset = Labset.add l senv'.labset; + revstruct = (l,SFBmodule mb)::senv'.revstruct; + univ = senv'.univ; + engagement = senv'.engagement; + imports = senv'.imports; + loads = senv'.loads; + local_retroknowledge = senv'.local_retroknowledge } + (* Interactive modules *) let start_module l senv = check_label l senv.labset; - let msid = make_msid senv.modinfo.seed (string_of_label l) in - let mp = MPself msid in - let modinfo = { msid = msid; - modpath = mp; - seed = senv.modinfo.seed; - label = l; - variant = STRUCT []; - alias_subst = empty_subst} - in - mp, { old = senv; - env = senv.env; - modinfo = modinfo; - labset = Labset.empty; - revstruct = []; - univ = Univ.Constraint.empty; - engagement = None; - imports = senv.imports; - loads = []; - (* spiwack : not sure, but I hope it's correct *) - local_retroknowledge = [] } + let mp = MPdot(senv.modinfo.modpath, l) in + let modinfo = { modpath = mp; + label = l; + variant = STRUCT []; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver} + in + mp, { old = senv; + env = senv.env; + modinfo = modinfo; + labset = Labset.empty; + revstruct = []; + univ = Univ.Constraint.empty; + engagement = None; + imports = senv.imports; + loads = []; + (* spiwack : not sure, but I hope it's correct *) + local_retroknowledge = [] } let end_module l restype senv = let oldsenv = senv.old in let modinfo = senv.modinfo in - let restype = Option.map (translate_struct_entry senv.env) restype in + let mp = senv.modinfo.modpath in + let restype = Option.map (translate_module_type senv.env mp) restype in let params,is_functor = match modinfo.variant with | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end () @@ -386,83 +355,107 @@ let end_module l restype senv = params in let auto_tb = - SEBstruct (modinfo.msid, List.rev senv.revstruct) + SEBstruct (List.rev senv.revstruct) in - let mod_typ,subst,cst = + let mexpr,mod_typ,mod_typ_alg,resolver,cst = match restype with - | None -> None,modinfo.alias_subst,Constraint.empty - | Some (res_tb,subst) -> - let cst = check_subtypes senv.env - {typ_expr = auto_tb; - typ_strength = None; - typ_alias = modinfo.alias_subst} - {typ_expr = res_tb; - typ_strength = None; - typ_alias = subst} in - let mtb = functorize_struct res_tb in - Some mtb,subst,cst + | None -> let mexpr = functorize_struct auto_tb in + mexpr,mexpr,None,modinfo.resolver,Constraint.empty + | Some mtb -> + let auto_mtb = { + typ_mp = senv.modinfo.modpath; + typ_expr = auto_tb; + typ_expr_alg = None; + typ_constraints = Constraint.empty; + typ_delta = empty_delta_resolver} in + let cst = check_subtypes senv.env auto_mtb + mtb in + let mod_typ = functorize_struct mtb.typ_expr in + let mexpr = functorize_struct auto_tb in + let typ_alg = + Option.map functorize_struct mtb.typ_expr_alg in + mexpr,mod_typ,typ_alg,mtb.typ_delta,cst in - let mexpr = functorize_struct auto_tb in let cst = Constraint.union cst senv.univ in let mb = - { mod_expr = Some mexpr; + { mod_mp = mp; + mod_expr = Some mexpr; mod_type = mod_typ; + mod_type_alg = mod_typ_alg; mod_constraints = cst; - mod_alias = subst; + mod_delta = resolver; mod_retroknowledge = senv.local_retroknowledge } in - let mp = MPdot (oldsenv.modinfo.modpath, l) in let newenv = oldsenv.env in let newenv = set_engagement_opt senv.engagement newenv in let senv'= {senv with env=newenv} in let senv' = List.fold_left - (fun env (mp,mb) -> full_add_module mp mb env) + (fun env (_,mb) -> full_add_module mb env) senv' (List.rev senv'.loads) in let newenv = Environ.add_constraints cst senv'.env in let newenv = - Modops.add_module mp mb newenv - in - let is_functor,subst = Modops.update_subst newenv mb mp in - let newmodinfo = - if is_functor then - oldsenv.modinfo - else - { oldsenv.modinfo with - alias_subst = join - oldsenv.modinfo.alias_subst - subst }; + Modops.add_module mb newenv in + let modinfo = match mb.mod_type with + SEBstruct _ -> + { oldsenv.modinfo with + resolver = + add_delta_resolver resolver oldsenv.modinfo.resolver} + | _ -> oldsenv.modinfo in - mp, { old = oldsenv.old; - env = newenv; - modinfo = newmodinfo; - labset = Labset.add l oldsenv.labset; - revstruct = (l,SFBmodule mb)::oldsenv.revstruct; - univ = Univ.Constraint.union senv'.univ oldsenv.univ; - (* engagement is propagated to the upper level *) - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads@oldsenv.loads; - local_retroknowledge = senv'.local_retroknowledge@oldsenv.local_retroknowledge } + mp,resolver,{ old = oldsenv.old; + env = newenv; + modinfo = modinfo; + labset = Labset.add l oldsenv.labset; + revstruct = (l,SFBmodule mb)::oldsenv.revstruct; + univ = Univ.Constraint.union senv'.univ oldsenv.univ; + (* engagement is propagated to the upper level *) + engagement = senv'.engagement; + imports = senv'.imports; + loads = senv'.loads@oldsenv.loads; + local_retroknowledge = + senv'.local_retroknowledge@oldsenv.local_retroknowledge } (* Include for module and module type*) - let add_include me senv = - let struct_expr,_ = translate_struct_entry senv.env me in - let senv = add_constraints (struct_expr_constraints struct_expr) senv in - let msid,str = match (eval_struct senv.env struct_expr) with - | SEBstruct(msid,str_l) -> msid,str_l - | _ -> error ("You cannot Include a higher-order Module or Module Type.") + let add_include me is_module senv = + let sign,cst,resolver = + if is_module then + let sign,resolver,cst = + translate_struct_include_module_entry senv.env + senv.modinfo.modpath me in + sign,cst,resolver + else + let mtb = + translate_module_type senv.env + senv.modinfo.modpath me in + mtb.typ_expr,mtb.typ_constraints,mtb.typ_delta in + let senv = add_constraints cst senv in let mp_sup = senv.modinfo.modpath in - let str1 = subst_signature_msid msid mp_sup str in + let str = match sign with + | SEBstruct(str_l) -> + str_l + | _ -> error ("You cannot Include a high-order structure.") + in + let senv = + {senv + with modinfo = + {senv.modinfo + with resolver = + add_delta_resolver resolver senv.modinfo.resolver}} + in let add senv (l,elem) = check_label l senv.labset; match elem with | SFBconst cb -> - let con = make_con mp_sup empty_dirpath l in + let kn = make_kn mp_sup empty_dirpath l in + let con = constant_of_kn_equiv kn + (canonical_con + (constant_of_delta resolver (constant_of_kn kn))) + in let senv' = add_constraints cb.const_constraints senv in let env'' = Environ.add_constant con cb senv'.env in { old = senv'.old; @@ -475,11 +468,14 @@ let end_module l restype senv = imports = senv'.imports; loads = senv'.loads ; local_retroknowledge = senv'.local_retroknowledge } - | SFBmind mib -> let kn = make_kn mp_sup empty_dirpath l in + let mind = mind_of_kn_equiv kn + (canonical_mind + (mind_of_delta resolver (mind_of_kn kn))) + in let senv' = add_constraints mib.mind_constraints senv in - let env'' = Environ.add_mind kn mib senv'.env in + let env'' = Environ.add_mind mind mib senv'.env in { old = senv'.old; env = env''; modinfo = senv'.modinfo; @@ -492,17 +488,10 @@ let end_module l restype senv = local_retroknowledge = senv'.local_retroknowledge } | SFBmodule mb -> - let mp = MPdot(senv.modinfo.modpath, l) in - let is_functor,sub = Modops.update_subst senv.env mb mp in - let senv' = full_add_module mp mb senv in + let senv' = full_add_module mb senv in { old = senv'.old; env = senv'.env; - modinfo = - if is_functor then - senv'.modinfo - else - {senv'.modinfo with - alias_subst = join senv'.modinfo.alias_subst sub}; + modinfo = senv'.modinfo; labset = Labset.add l senv'.labset; revstruct = (l,SFBmodule mb)::senv'.revstruct; univ = senv'.univ; @@ -510,87 +499,69 @@ let end_module l restype senv = imports = senv'.imports; loads = senv'.loads; local_retroknowledge = senv'.local_retroknowledge } - | SFBalias (mp',typ_opt,cst) -> - let env' = Option.fold_right - Environ.add_constraints cst senv.env in - let mp = MPdot(senv.modinfo.modpath, l) in - let mp1 = scrape_alias mp' senv.env in - let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in - let sub = update_subst sub (map_mp mp mp1) in - let sub = join_alias sub (map_mp mp mp1) in - let sub = add_mp mp mp1 sub in - let env' = register_alias mp mp' env' in - { old = senv.old; - env = env'; - modinfo = { senv.modinfo with - alias_subst = join - senv.modinfo.alias_subst sub}; - labset = Labset.add l senv.labset; - revstruct = (l,SFBalias (mp',typ_opt,cst))::senv.revstruct; - univ = senv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = senv.loads; - local_retroknowledge = senv.local_retroknowledge } | SFBmodtype mtb -> - let env' = add_modtype_constraints senv.env mtb in + let senv' = add_constraints mtb.typ_constraints senv in let mp = MPdot(senv.modinfo.modpath, l) in - let env'' = Environ.add_modtype mp mtb env' in + let env' = Environ.add_modtype mp mtb senv'.env in { old = senv.old; - env = env''; - modinfo = senv.modinfo; + env = env'; + modinfo = senv'.modinfo; labset = Labset.add l senv.labset; - revstruct = (l,SFBmodtype mtb)::senv.revstruct; - univ = senv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = senv.loads; - local_retroknowledge = senv.local_retroknowledge } + revstruct = (l,SFBmodtype mtb)::senv'.revstruct; + univ = senv'.univ; + engagement = senv'.engagement; + imports = senv'.imports; + loads = senv'.loads; + local_retroknowledge = senv'.local_retroknowledge } in - List.fold_left add senv str1 + resolver,(List.fold_left add senv str) (* Adding parameters to modules or module types *) let add_module_parameter mbid mte senv = if senv.revstruct <> [] or senv.loads <> [] then anomaly "Cannot add a module parameter to a non empty module"; - let mtb_expr,sub = translate_struct_entry senv.env mte in - let mtb = {typ_expr = mtb_expr; - typ_strength = None; - typ_alias = sub} in - let senv = full_add_module (MPbound mbid) (module_body_of_type mtb) senv + let mtb = translate_module_type senv.env (MPbound mbid) mte in + let senv = + full_add_module (module_body_of_type (MPbound mbid) mtb) senv in let new_variant = match senv.modinfo.variant with | STRUCT params -> STRUCT ((mbid,mtb) :: params) | SIG params -> SIG ((mbid,mtb) :: params) | _ -> - anomaly "Module parameters can only be added to modules or signatures" + anomaly "Module parameters can only be added to modules or signatures" in - { old = senv.old; - env = senv.env; - modinfo = { senv.modinfo with variant = new_variant }; - labset = senv.labset; - revstruct = []; - univ = senv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = []; - local_retroknowledge = senv.local_retroknowledge } - + + let resolver_of_param = match mtb.typ_expr with + SEBstruct _ -> mtb.typ_delta + | _ -> empty_delta_resolver + in + mtb.typ_delta, { old = senv.old; + env = senv.env; + modinfo = { senv.modinfo with + variant = new_variant; + resolver_of_param = add_delta_resolver + resolver_of_param senv.modinfo.resolver_of_param}; + labset = senv.labset; + revstruct = []; + univ = senv.univ; + engagement = senv.engagement; + imports = senv.imports; + loads = []; + local_retroknowledge = senv.local_retroknowledge } + (* Interactive module types *) let start_modtype l senv = check_label l senv.labset; - let msid = make_msid senv.modinfo.seed (string_of_label l) in - let mp = MPself msid in - let modinfo = { msid = msid; - modpath = mp; - seed = senv.modinfo.seed; - label = l; - variant = SIG []; - alias_subst = empty_subst } - in + let mp = MPdot(senv.modinfo.modpath, l) in + let modinfo = { modpath = mp; + label = l; + variant = SIG []; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver} + in mp, { old = senv; env = senv.env; modinfo = modinfo; @@ -614,7 +585,7 @@ let end_modtype l senv = if l <> modinfo.label then error_incompatible_labels l modinfo.label; if not (empty_context senv.env) then error_local_context None; let auto_tb = - SEBstruct (modinfo.msid, List.rev senv.revstruct) + SEBstruct (List.rev senv.revstruct) in let mtb_expr = List.fold_left @@ -625,42 +596,39 @@ let end_modtype l senv = in let mp = MPdot (oldsenv.modinfo.modpath, l) in let newenv = oldsenv.env in - (* since universes constraints cannot be stored in the modtype, - they are propagated to the upper level *) let newenv = Environ.add_constraints senv.univ newenv in let newenv = set_engagement_opt senv.engagement newenv in let senv = {senv with env=newenv} in let senv = List.fold_left - (fun env (mp,mb) -> full_add_module mp mb env) + (fun env (mp,mb) -> full_add_module mb env) senv (List.rev senv.loads) in - let subst = senv.modinfo.alias_subst in - let mtb = {typ_expr = mtb_expr; - typ_strength = None; - typ_alias = subst} in + let mtb = {typ_mp = mp; + typ_expr = mtb_expr; + typ_expr_alg = None; + typ_constraints = senv.univ; + typ_delta = senv.modinfo.resolver} in let newenv = Environ.add_modtype mp mtb senv.env in mp, { old = oldsenv.old; env = newenv; - modinfo = oldsenv.modinfo; - labset = Labset.add l oldsenv.labset; - revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct; - univ = Univ.Constraint.union senv.univ oldsenv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = senv.loads@oldsenv.loads; - (* spiwack : if there is a bug with retroknowledge in nested modules - it's likely to come from here *) - local_retroknowledge = - senv.local_retroknowledge@oldsenv.local_retroknowledge} - + modinfo = oldsenv.modinfo; + labset = Labset.add l oldsenv.labset; + revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct; + univ = Univ.Constraint.union senv.univ oldsenv.univ; + engagement = senv.engagement; + imports = senv.imports; + loads = senv.loads@oldsenv.loads; + (* spiwack : if there is a bug with retroknowledge in nested modules + it's likely to come from here *) + local_retroknowledge = + senv.local_retroknowledge@oldsenv.local_retroknowledge} let current_modpath senv = senv.modinfo.modpath -let current_msid senv = senv.modinfo.msid - +let delta_of_senv senv = senv.modinfo.resolver,senv.modinfo.resolver_of_param (* Check that the engagement expected by a library matches the initial one *) let check_engagement env c = @@ -685,7 +653,7 @@ type compiled_library = let is_empty senv = senv.revstruct = [] && - senv.modinfo.msid = initial_msid && + senv.modinfo.modpath = initial_path && senv.modinfo.variant = NONE let start_library dir senv = @@ -697,14 +665,12 @@ let start_library dir senv = | hd::tl -> make_dirpath tl, label_of_id hd in - let msid = make_msid dir_path (string_of_label l) in - let mp = MPself msid in - let modinfo = { msid = msid; - modpath = mp; - seed = dir; - label = l; - variant = LIBRARY dir; - alias_subst = empty_subst } + let mp = MPfile dir in + let modinfo = {modpath = mp; + label = l; + variant = LIBRARY dir; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver} in mp, { old = senv; env = senv.env; @@ -731,14 +697,18 @@ let export senv dir = end; (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then (* error_export_simple *) (); *) - let mb = - { mod_expr = Some (SEBstruct (modinfo.msid, List.rev senv.revstruct)); - mod_type = None; + let str = SEBstruct (List.rev senv.revstruct) in + let mp = senv.modinfo.modpath in + let mb = + { mod_mp = mp; + mod_expr = Some str; + mod_type = str; + mod_type_alg = None; mod_constraints = senv.univ; - mod_alias = senv.modinfo.alias_subst; + mod_delta = senv.modinfo.resolver; mod_retroknowledge = senv.local_retroknowledge} in - modinfo.msid, (dir,mb,senv.imports,engagement senv.env) + mp, (dir,mb,senv.imports,engagement senv.env) let check_imports senv needed = @@ -775,9 +745,13 @@ let import (dp,mb,depends,engmt) digest senv = let mp = MPfile dp in let env = senv.env in let env = Environ.add_constraints mb.mod_constraints env in - let env = Modops.add_module mp mb env in + let env = Modops.add_module mb env in mp, { senv with env = env; + modinfo = + {senv.modinfo with + resolver = + add_delta_resolver mb.mod_delta senv.modinfo.resolver}; imports = (dp,digest)::senv.imports; loads = (mp,mb)::senv.loads } @@ -785,14 +759,14 @@ let import (dp,mb,depends,engmt) digest senv = (* Remove the body of opaque constants in modules *) let rec lighten_module mb = { mb with - mod_expr = Option.map lighten_modexpr mb.mod_expr; - mod_type = Option.map lighten_modexpr mb.mod_type; + mod_expr = None; + mod_type = lighten_modexpr mb.mod_type; } and lighten_struct struc = let lighten_body (l,body) = (l,match body with | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None} - | (SFBconst _ | SFBmind _ | SFBalias _) as x -> x + | (SFBconst _ | SFBmind _ ) as x -> x | SFBmodule m -> SFBmodule (lighten_module m) | SFBmodtype m -> SFBmodtype ({m with @@ -807,8 +781,8 @@ and lighten_modexpr = function typ_expr = lighten_modexpr mty.typ_expr}), lighten_modexpr mexpr) | SEBident mp as x -> x - | SEBstruct (msid, struc) -> - SEBstruct (msid, lighten_struct struc) + | SEBstruct (struc) -> + SEBstruct (lighten_struct struc) | SEBapply (mexpr,marg,u) -> SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u) | SEBwith (seb,wdcl) -> diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index ac1e3863a..f011d42b7 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -13,6 +13,7 @@ open Names open Term open Declarations open Entries +open Mod_subst (*i*) (*s Safe environments. Since we are now able to type terms, we can @@ -55,12 +56,8 @@ val add_mind : (* Adding a module *) val add_module : label -> module_entry -> safe_environment - -> module_path * safe_environment + -> module_path * delta_resolver * safe_environment -(* Adding a module alias*) -val add_alias : - label -> module_path -> safe_environment - -> module_path * safe_environment (* Adding a module type *) val add_modtype : label -> module_struct_entry -> safe_environment @@ -77,12 +74,13 @@ val set_engagement : engagement -> safe_environment -> safe_environment (*s Interactive module functions *) val start_module : label -> safe_environment -> module_path * safe_environment + val end_module : - label -> module_struct_entry option - -> safe_environment -> module_path * safe_environment + label -> module_struct_entry option + -> safe_environment -> module_path * delta_resolver * safe_environment val add_module_parameter : - mod_bound_id -> module_struct_entry -> safe_environment -> safe_environment + mod_bound_id -> module_struct_entry -> safe_environment -> delta_resolver * safe_environment val start_modtype : label -> safe_environment -> module_path * safe_environment @@ -91,12 +89,11 @@ val end_modtype : label -> safe_environment -> module_path * safe_environment val add_include : - module_struct_entry -> safe_environment -> safe_environment + module_struct_entry -> bool -> safe_environment -> delta_resolver * safe_environment val current_modpath : safe_environment -> module_path -val current_msid : safe_environment -> mod_self_id - - +val delta_of_senv : safe_environment -> delta_resolver*delta_resolver + (* Loading and saving compilation units *) (* exporting and importing modules *) @@ -106,7 +103,7 @@ val start_library : dir_path -> safe_environment -> module_path * safe_environment val export : safe_environment -> dir_path - -> mod_self_id * compiled_library + -> module_path * compiled_library val import : compiled_library -> Digest.t -> safe_environment -> module_path * safe_environment diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 861dc9a3f..41f4c640c 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -33,7 +33,6 @@ type namedobject = | IndConstr of constructor * mutual_inductive_body | Module of module_body | Modtype of module_type_body - | Alias of module_path * struct_expr_body option (* adds above information about one mutual inductive: all types and constructors *) @@ -61,10 +60,9 @@ let make_label_map mp list = match e with | SFBconst cb -> add_map (Constant cb) | SFBmind mib -> - add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map + add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map | SFBmodule mb -> add_map (Module mb) | SFBmodtype mtb -> add_map (Modtype mtb) - | SFBalias (mp,typ_opt,cst) -> add_map (Alias (mp,typ_opt)) in List.fold_right add_one list Labmap.empty @@ -75,15 +73,18 @@ let check_conv_error error cst f env a1 a2 = NotConvertible -> error () (* for now we do not allow reorderings *) -let check_inductive cst env msid1 l info1 mib2 spec2 = - let kn = make_kn (MPself msid1) empty_dirpath l in + +let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= + let kn1 = make_mind mp1 empty_dirpath l in + let kn2 = make_mind mp2 empty_dirpath l in let error () = error_not_match l spec2 in let check_conv cst f = check_conv_error error cst f in let mib1 = match info1 with - | IndType ((_,0), mib) -> mib + | IndType ((_,0), mib) -> subst_mind subst1 mib | _ -> error () in + let mib2 = subst_mind subst2 mib2 in let check_inductive_type cst env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of @@ -141,8 +142,8 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = array_fold_left2 (fun cst t1 t2 -> check_conv cst conv env t1 t2) cst - (arities_of_specif kn (mib1,p1)) - (arities_of_specif kn (mib2,p2)) + (arities_of_specif kn1 (mib1,p1)) + (arities_of_specif kn1 (mib2,p2)) in let check f = if f mib1 <> f mib2 then error () in check (fun mib -> mib.mind_finite); @@ -158,16 +159,12 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams); - begin - match mib2.mind_equiv with - | None -> () - | Some kn2' -> - let kn2 = scrape_mind env kn2' in - let kn1 = match mib1.mind_equiv with - None -> kn - | Some kn1' -> scrape_mind env kn1' - in - if kn1 <> kn2 then error () + begin + match mind_of_delta reso2 kn2 with + | kn2' when kn2=kn2' -> () + | kn2' -> + if not (eq_mind (mind_of_delta reso1 kn1) kn2') then + error () end; (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record); @@ -194,7 +191,8 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = in cst -let check_constant cst env msid1 l info1 cb2 spec2 = + +let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let error () = error_not_match l spec2 in let check_conv cst f = check_conv_error error cst f in let check_type cst env t1 t2 = @@ -245,13 +243,15 @@ let check_constant cst env msid1 l info1 cb2 spec2 = in match info1 with - | Constant cb1 -> - assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; - (*Start by checking types*) + | Constant cb1 -> + assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; + (*Start by checking types*) + let cb1 = subst_const_body subst1 cb1 in + let cb2 = subst_const_body subst2 cb2 in let typ1 = Typeops.type_of_constant_type env cb1.const_type in let typ2 = Typeops.type_of_constant_type env cb2.const_type in let cst = check_type cst env typ1 typ2 in - let con = make_con (MPself msid1) empty_dirpath l in + let con = make_con mp1 empty_dirpath l in let cst = if cb2.const_opaque then match cb2.const_body with @@ -264,7 +264,8 @@ let check_constant cst env msid1 l info1 cb2 spec2 = begin match (kind_of_term c) with Const n -> - let cb = lookup_constant n env in + let cb = subst_const_body subst1 + (lookup_constant n env) in (match cb.const_opaque, cb.const_body with | true, Some lc1 -> @@ -311,28 +312,13 @@ let check_constant cst env msid1 l info1 cb2 spec2 = check_conv cst conv env ty1 ty2 | _ -> error () -let rec check_modules cst env msid1 l msb1 msb2 alias = - let mp = (MPdot(MPself msid1,l)) in - let mty1 = module_type_of_module (Some mp) msb1 in - let alias1,struct_expr = match eval_struct env mty1.typ_expr with - | SEBstruct (msid,sign) as str -> - update_subst alias (map_msid msid mp),str - | _ as str -> empty_subst,str in - let mty1 = {mty1 with - typ_expr = struct_expr; - typ_alias = join alias1 mty1.typ_alias } in - let mty2 = module_type_of_module None msb2 in - let cst = check_modtypes cst env mty1 mty2 false in +let rec check_modules cst env msb1 msb2 subst1 subst2 = + let mty1 = module_type_of_module env None msb1 in + let mty2 = module_type_of_module env None msb2 in + let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in cst - -and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = - let mp1 = MPself msid1 in - let env = add_signature mp1 sig1 env in - let sig1 = subst_structure alias sig1 in - let alias1 = update_subst alias (map_msid msid2 mp1) in - let sig2 = subst_structure alias1 sig2' in - let sig2 = subst_signature_msid msid2 mp1 sig2 in +and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= let map1 = make_label_map mp1 sig1 in let check_one_body cst (l,spec2) = let info1 = @@ -340,38 +326,19 @@ and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = Labmap.find l map1 with Not_found -> error_no_such_label_sub l - (string_of_msid msid1) (string_of_msid msid2) + (string_of_mp mp1) in match spec2 with | SFBconst cb2 -> - check_constant cst env msid1 l info1 cb2 spec2 + check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 | SFBmind mib2 -> - check_inductive cst env msid1 l info1 mib2 spec2 + check_inductive cst env + mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 | SFBmodule msb2 -> begin match info1 with - | Module msb -> check_modules cst env msid1 l msb msb2 alias - | Alias (mp,typ_opt) ->let msb = - {mod_expr = Some (SEBident mp); - mod_type = typ_opt; - mod_constraints = Constraint.empty; - mod_alias = (lookup_modtype mp env).typ_alias; - mod_retroknowledge = []} in - check_modules cst env msid1 l msb msb2 alias - | _ -> error_not_match l spec2 - end - | SFBalias (mp,typ_opt,_) -> - begin - match info1 with - | Alias (mp1,_) -> check_modpath_equiv env mp mp1; cst - | Module msb -> - let msb1 = - {mod_expr = Some (SEBident mp); - mod_type = typ_opt; - mod_constraints = Constraint.empty; - mod_alias = (lookup_modtype mp env).typ_alias; - mod_retroknowledge = []} in - check_modules cst env msid1 l msb msb1 alias + | Module msb -> check_modules cst env msb msb2 + subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> @@ -380,50 +347,69 @@ and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = | Modtype mtb -> mtb | _ -> error_not_match l spec2 in - check_modtypes cst env mtb1 mtb2 true + let env = add_module (module_body_of_type mtb2.typ_mp mtb2) + (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in + check_modtypes cst env mtb1 mtb2 subst1 subst2 true in List.fold_left check_one_body cst sig2 - -and check_modtypes cst env mtb1 mtb2 equiv = - if mtb1==mtb2 then cst else (* just in case :) *) - let mtb1',mtb2'= - (match mtb1.typ_strength with - None -> eval_struct env mtb1.typ_expr, - eval_struct env mtb2.typ_expr - | Some mp -> strengthen env mtb1.typ_expr mp, - eval_struct env mtb2.typ_expr) in - let rec check_structure cst env str1 str2 equiv = - match str1, str2 with - | SEBstruct (msid1,list1), - SEBstruct (msid2,list2) -> - let cst = check_signatures cst env - (msid1,list1) mtb1.typ_alias (msid2,list2) in - if equiv then - check_signatures cst env - (msid2,list2) mtb2.typ_alias (msid1,list1) - else - cst +and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = + if mtb1==mtb2 then cst else + let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in + let rec check_structure cst env str1 str2 equiv subst1 subst2 = + match str1,str2 with + | SEBstruct (list1), + SEBstruct (list2) -> + if equiv then + let subst2 = + add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in + Univ.Constraint.union + (check_signatures cst env + mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 + mtb1.typ_delta mtb2.typ_delta) + (check_signatures cst env + mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1 + mtb2.typ_delta mtb1.typ_delta) + else + check_signatures cst env + mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 + mtb1.typ_delta mtb2.typ_delta | SEBfunctor (arg_id1,arg_t1,body_t1), SEBfunctor (arg_id2,arg_t2,body_t2) -> - let cst = check_modtypes cst env arg_t2 arg_t1 equiv in + let subst1 = + (join (map_mbid arg_id1 (MPbound arg_id2) arg_t2.typ_delta) subst1) in + let cst = check_modtypes cst env + arg_t2 arg_t1 subst2 subst1 + equiv in (* contravariant *) - let env = - add_module (MPbound arg_id2) (module_body_of_type arg_t2) env + let env = add_module + (module_body_of_type (MPbound arg_id2) arg_t2) env in - let body_t1' = - (* since we are just checking well-typedness we do not need - to expand any constant. Hence the identity resolver. *) - subst_struct_expr - (map_mbid arg_id1 (MPbound arg_id2) None) - body_t1 + let subst1 = + (join (map_mbid arg_id1 (MPbound arg_id2) arg_t2.typ_delta) subst1) in + let env = match body_t1 with + SEBstruct str -> + add_module {mod_mp = mtb1.typ_mp; + mod_expr = None; + mod_type = subst_struct_expr subst1 body_t1; + mod_type_alg= None; + mod_constraints=mtb1.typ_constraints; + mod_retroknowledge = []; + mod_delta = mtb1.typ_delta} env + | _ -> env in - check_structure cst env (eval_struct env body_t1') - (eval_struct env body_t2) equiv + check_structure cst env body_t1 body_t2 equiv + subst1 + subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 in if mtb1'== mtb2' then cst - else check_structure cst env mtb1' mtb2' equiv + else check_structure cst env mtb1' mtb2' equiv subst1 subst2 let check_subtypes env sup super = - check_modtypes Constraint.empty env sup super false + let env = add_module + (module_body_of_type sup.typ_mp sup) env in + check_modtypes Constraint.empty env + (strengthen env sup sup.typ_mp) super empty_subst + (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false + diff --git a/kernel/term.ml b/kernel/term.ml index 68ea2ed3f..685656592 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -184,7 +184,7 @@ module Hconstr = type t = constr type u = (constr -> constr) * ((sorts -> sorts) * (constant -> constant) * - (kernel_name -> kernel_name) * (name -> name) * + (mutual_inductive -> mutual_inductive) * (name -> name) * (identifier -> identifier)) let hash_sub = hash_term let equal = comp_term @@ -609,6 +609,7 @@ let map_constr_with_binders g f l c = match kind_of_term c with application associativity, binders name and Cases annotations are not taken into account *) + let compare_constr f t1 t2 = match kind_of_term t1, kind_of_term t2 with | Rel n1, Rel n2 -> n1 = n2 @@ -630,9 +631,9 @@ let compare_constr f t1 t2 = f h1 h2 & List.for_all2 f l1 l2 else false | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 - | Const c1, Const c2 -> c1 = c2 - | Ind c1, Ind c2 -> c1 = c2 - | Construct c1, Construct c2 -> c1 = c2 + | Const c1, Const c2 -> eq_constant c1 c2 + | Ind c1, Ind c2 -> eq_ind c1 c2 + | Construct c1, Construct c2 -> eq_constructor c1 c2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> diff --git a/kernel/term.mli b/kernel/term.mli index 5929250db..0de831668 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -595,7 +595,7 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val hcons_constr: (constant -> constant) * - (kernel_name -> kernel_name) * + (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) * (name -> name) * (identifier -> identifier) * diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 0dd119f7b..a35d1d88e 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -83,7 +83,7 @@ and conv_whd pb k whd1 whd2 cu = and conv_atom pb k a1 stk1 a2 stk2 cu = match a1, a2 with | Aind (kn1,i1), Aind(kn2,i2) -> - if mind_equiv_infos !infos (kn1,i1) (kn2,i2) && compare_stack stk1 stk2 + if eq_ind (kn1,i1) (kn2,i2) && compare_stack stk1 stk2 then conv_stack k stk1 stk2 cu else raise NotConvertible @@ -94,7 +94,7 @@ and conv_atom pb k a1 stk1 a2 stk2 cu = | Aiddef(ik1,v1), Aiddef(ik2,v2) -> begin try - if ik1 = ik2 && compare_stack stk1 stk2 then + if eq_table_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack k stk1 stk2 cu else raise NotConvertible with NotConvertible -> @@ -191,11 +191,11 @@ let rec conv_eq pb t1 t2 cu = if e1 = e2 then conv_eq_vect l1 l2 cu else raise NotConvertible | Const c1, Const c2 -> - if c1 = c2 then cu else raise NotConvertible + if eq_constant c1 c2 then cu else raise NotConvertible | Ind c1, Ind c2 -> - if c1 = c2 then cu else raise NotConvertible + if eq_ind c1 c2 then cu else raise NotConvertible | Construct c1, Construct c2 -> - if c1 = c2 then cu else raise NotConvertible + if eq_constructor c1 c2 then cu else raise NotConvertible | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> let pcu = conv_eq CONV p1 p2 cu in let ccu = conv_eq CONV c1 c2 pcu in diff --git a/lib/lib.mllib b/lib/lib.mllib index 2321abd1b..56fe32cbd 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -13,6 +13,7 @@ Edit Gset Gmap Tlm +tries Gmapl Profile Explore diff --git a/lib/tries.ml b/lib/tries.ml new file mode 100644 index 000000000..1159ea233 --- /dev/null +++ b/lib/tries.ml @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + + + +module Make = + functor (X : Set.OrderedType) -> + functor (Y : Map.OrderedType) -> +struct + module T_dom = Set.Make(X) + module T_codom = Map.Make(Y) + + type t = Node of T_dom.t * t T_codom.t + + let codom_to_list m = T_codom.fold (fun x y l -> (x,y)::l) m [] + + let codom_rng m = T_codom.fold (fun _ y acc -> y::acc) m [] + + let codom_dom m = T_codom.fold (fun x _ acc -> x::acc) m [] + + let empty = Node (T_dom.empty, T_codom.empty) + + let map (Node (_,m)) lbl = T_codom.find lbl m + + let xtract (Node (hereset,_)) = T_dom.elements hereset + + let dom (Node (_,m)) = codom_dom m + + let in_dom (Node (_,m)) lbl = T_codom.mem lbl m + + let is_empty_node (Node(a,b)) = (T_dom.elements a = []) & (codom_to_list b = []) + +let assure_arc m lbl = + if T_codom.mem lbl m then + m + else + T_codom.add lbl (Node (T_dom.empty,T_codom.empty)) m + +let cleanse_arcs (Node (hereset,m)) = + let l = codom_rng m in + Node(hereset, if List.for_all is_empty_node l then T_codom.empty else m) + +let rec at_path f (Node (hereset,m)) = function + | [] -> + cleanse_arcs (Node(f hereset,m)) + | h::t -> + let m = assure_arc m h in + cleanse_arcs (Node(hereset, + T_codom.add h (at_path f (T_codom.find h m) t) m)) + +let add tm (path,v) = + at_path (fun hereset -> T_dom.add v hereset) tm path + +let rmv tm (path,v) = + at_path (fun hereset -> T_dom.remove v hereset) tm path + +let app f tlm = + let rec apprec pfx (Node(hereset,m)) = + let path = List.rev pfx in + T_dom.iter (fun v -> f(path,v)) hereset; + T_codom.iter (fun l tm -> apprec (l::pfx) tm) m + in + apprec [] tlm + +let to_list tlm = + let rec torec pfx (Node(hereset,m)) = + let path = List.rev pfx in + List.flatten((List.map (fun v -> (path,v)) (T_dom.elements hereset)):: + (List.map (fun (l,tm) -> torec (l::pfx) tm) (codom_to_list m))) + in + torec [] tlm + +end diff --git a/lib/tries.mli b/lib/tries.mli new file mode 100644 index 000000000..342c81ecd --- /dev/null +++ b/lib/tries.mli @@ -0,0 +1,34 @@ + + + + + +module Make : + functor (X : Set.OrderedType) -> + functor (Y : Map.OrderedType) -> +sig + + type t + + val empty : t + + (* Work on labels, not on paths. *) + + val map : t -> Y.t -> t + + val xtract : t -> X.t list + + val dom : t -> Y.t list + + val in_dom : t -> Y.t -> bool + + (* Work on paths, not on labels. *) + + val add : t -> Y.t list * X.t -> t + + val rmv : t -> Y.t list * X.t -> t + + val app : ((Y.t list * X.t) -> unit) -> t -> unit + + val to_list : t -> (Y.t list * X.t) list +end diff --git a/library/declare.ml b/library/declare.ml index da723aa4b..1084aa07d 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -100,12 +100,14 @@ let load_constant i ((sp,kn),(_,_,kind)) = if Nametab.exists_cci sp then errorlabstrm "cache_constant" (pr_id (basename sp) ++ str " already exists"); - Nametab.push (Nametab.Until i) sp (ConstRef (constant_of_kn kn)); - add_constant_kind (constant_of_kn kn) kind - + let con = Global.constant_of_delta (constant_of_kn kn) in + Nametab.push (Nametab.Until i) sp (ConstRef con); + add_constant_kind con kind + (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn),_) = - Nametab.push (Nametab.Exactly i) sp (ConstRef (constant_of_kn kn)) + let con = constant_of_kn kn in + Nametab.push (Nametab.Exactly i) sp (ConstRef con) let cache_constant ((sp,kn),(cdt,dhyps,kind)) = let id = basename sp in @@ -187,6 +189,7 @@ let declare_inductive_argument_scopes kn mie = let inductive_names sp kn mie = let (dp,_) = repr_path sp in + let kn = Global.mind_of_delta (mind_of_kn kn) in let names, _ = List.fold_left (fun (names, n) ind -> @@ -228,17 +231,18 @@ let cache_inductive ((sp,kn),(dhyps,mie)) = let id = basename sp in let _,dir,_ = repr_kn kn in let kn' = Global.add_mind dir id mie in - assert (kn'=kn); - add_section_kn kn (Global.lookup_mind kn').mind_hyps; + assert (kn'= mind_of_kn kn); + add_section_kn kn' (Global.lookup_mind kn').mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names; List.iter (fun (sp,_) -> !cache_hook sp) (inductive_names sp kn mie) let discharge_inductive ((sp,kn),(dhyps,mie)) = - let mie = Global.lookup_mind kn in + let mind = (Global.mind_of_delta (mind_of_kn kn)) in + let mie = Global.lookup_mind mind in let repl = replacement_context () in - let sechyps = section_segment_of_mutual_inductive kn in + let sechyps = section_segment_of_mutual_inductive mind in Some (discharged_hyps kn sechyps, Discharge.process_inductive (named_of_variable_context sechyps) repl mie) @@ -271,8 +275,9 @@ let declare_mind isrecord mie = | ind::_ -> ind.mind_entry_typename | [] -> anomaly "cannot declare an empty list of inductives" in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in - declare_mib_implicits kn; - declare_inductive_argument_scopes kn mie; + let mind = (Global.mind_of_delta (mind_of_kn kn)) in + declare_mib_implicits mind; + declare_inductive_argument_scopes mind mie; !xml_declare_inductive (isrecord,oname); oname diff --git a/library/declaremods.ml b/library/declaremods.ml index d796a2906..548a9b0f3 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -22,7 +22,7 @@ open Mod_subst (* modules and components *) -(* This type is a functional closure of substitutive lib_objects. +(* OBSOLETE This type is a functional closure of substitutive lib_objects. The first part is a partial substitution (which will be later applied to lib_objects when completed). @@ -41,7 +41,7 @@ open Mod_subst *) type substitutive_objects = - substitution * mod_bound_id list * mod_self_id * lib_objects + mod_bound_id list * module_path * lib_objects (* For each module, we store the following things: @@ -77,9 +77,10 @@ let modtab_objects = (* currently started interactive module (if any) - its arguments (if it is a functor) and declared output type *) -let openmod_info = - ref (([],None,None) : mod_bound_id list * module_struct_entry option - * struct_expr_body option) +let openmod_info = + ref ((MPfile(initial_dir),[],None,None) + : module_path * mod_bound_id list * module_struct_entry option + * module_type_body option) (* The library_cache here is needed to avoid recalculations of substituted modules object during "reloading" of libraries *) @@ -99,7 +100,8 @@ let _ = Summary.declare_summary "MODULE-INFO" Summary.init_function = (fun () -> modtab_substobjs := MPmap.empty; modtab_objects := MPmap.empty; - openmod_info := ([],None,None); + openmod_info := ((MPfile(initial_dir), + [],None,None)); library_cache := Dirmap.empty) } (* auxiliary functions to transform full_path and kernel_name given @@ -116,50 +118,18 @@ let dir_of_sp sp = let dir,id = repr_path sp in add_dirpath_suffix dir id -let msid_of_mp = function - MPself msid -> msid - | _ -> anomaly "'Self' module path expected!" - -let msid_of_prefix (_,(mp,sec)) = - if sec=empty_dirpath then - msid_of_mp mp - else - anomaly ("Non-empty section in module name!" ^ - string_of_mp mp ^ "." ^ string_of_dirpath sec) - -let scrape_alias mp = - Environ.scrape_alias mp (Global.env()) - (* This function checks if the type calculated for the module [mp] is a subtype of [sub_mtb]. Uses only the global environment. *) let check_subtypes mp sub_mtb = let env = Global.env () in - let mtb = Environ.lookup_modtype mp env in - let sub_mtb = - {typ_expr = sub_mtb; - typ_strength = None; - typ_alias = empty_subst} in - let _ = Environ.add_constraints - (Subtyping.check_subtypes env mtb sub_mtb) + let mb = Environ.lookup_module mp env in + let mtb = Modops.module_type_of_module env None mb in + let _ = Environ.add_constraints + (Subtyping.check_subtypes env mtb sub_mtb) in () (* The constraints are checked and forgot immediately! *) -let compute_subst_objects mp (subst,mbids,msid,objs) = - match mbids with - | [] -> - let subst' = join_alias (map_msid msid mp) subst in - Some (join (map_msid msid mp) (join subst' subst), objs) - | _ -> - None - -let subst_substobjs dir mp substobjs = - match compute_subst_objects mp substobjs with - | Some (subst, objs) -> - let prefix = dir,(mp,empty_dirpath) in - Some (subst_objects prefix subst objs) - | None -> None - (* These functions register the visibility of the module and iterates through its components. They are called by plenty module functions *) @@ -178,12 +148,12 @@ let compute_visibility exists what i dir dirinfo = errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists") else Nametab.Until i - +(* let do_load_and_subst_module i dir mp substobjs keep = let prefix = (dir,(mp,empty_dirpath)) in let dirinfo = DirModule (dir,(mp,empty_dirpath)) in let vis = compute_visibility false "load_and_subst" i dir dirinfo in - let objects = compute_subst_objects mp substobjs in + let objects = compute_subst_objects mp substobjs resolver in Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; match objects with @@ -194,55 +164,33 @@ let do_load_and_subst_module i dir mp substobjs keep = Some (seg@keep) | None -> None +*) -let do_module exists what iter_objects i dir mp substobjs objects = +let do_module exists what iter_objects i dir mp substobjs keep= let prefix = (dir,(mp,empty_dirpath)) in let dirinfo = DirModule (dir,(mp,empty_dirpath)) in let vis = compute_visibility exists what i dir dirinfo in Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; - match objects with - Some seg -> - modtab_objects := MPmap.add mp (prefix,seg) !modtab_objects; - iter_objects (i+1) prefix seg - | None -> () + match substobjs with + ([],mp1,objs) -> + modtab_objects := MPmap.add mp (prefix,objs@keep) !modtab_objects; + iter_objects (i+1) prefix (objs@keep) + | (mbids,_,_) -> () let conv_names_do_module exists what iter_objects i - (sp,kn) substobjs substituted = + (sp,kn) substobjs = let dir,mp = dir_of_sp sp, mp_of_kn kn in - do_module exists what iter_objects i dir mp substobjs substituted + do_module exists what iter_objects i dir mp substobjs [] (* Interactive modules and module types cannot be recached! cache_mod* functions can be called only once (and "end_mod*" set the flag to false then) *) - -let cache_module ((sp,kn as oname),(entry,substobjs,substituted)) = - let _ = match entry with - | None -> - anomaly "You must not recache interactive modules!" - | Some (me,sub_mte_o) -> - let sub_mtb_o = match sub_mte_o with - None -> None - | Some mte -> Some (Mod_typing.translate_struct_entry - (Global.env()) mte) - in - - let mp = Global.add_module (basename sp) me in - if mp <> mp_of_kn kn then - anomaly "Kernel and Library names do not match"; - - match sub_mtb_o with - None -> () - | Some (sub_mtb,sub) -> - check_subtypes mp sub_mtb - - in - conv_names_do_module false "cache" load_objects 1 oname substobjs substituted - - - - +let cache_module ((sp,kn),(entry,substobjs)) = + let dir,mp = dir_of_sp sp, mp_of_kn kn in + do_module false "cache" load_objects 1 dir mp substobjs [] + (* TODO: This check is not essential *) let check_empty s = function | None -> () @@ -253,42 +201,26 @@ let check_empty s = function (* When this function is called the module itself is already in the environment. This function loads its objects only *) -let load_module i (oname,(entry,substobjs,substituted)) = +let load_module i (oname,(entry,substobjs)) = (* TODO: This check is not essential *) check_empty "load_module" entry; - conv_names_do_module false "load" load_objects i oname substobjs substituted + conv_names_do_module false "load" load_objects i oname substobjs -let open_module i (oname,(entry,substobjs,substituted)) = +let open_module i (oname,(entry,substobjs)) = (* TODO: This check is not essential *) check_empty "open_module" entry; - conv_names_do_module true "open" open_objects i oname substobjs substituted + conv_names_do_module true "open" open_objects i oname substobjs -let subst_module ((sp,kn),subst,(entry,substobjs,_)) = +let subst_module (subst,(entry,(mbids,mp,objs))) = check_empty "subst_module" entry; - let dir,mp = dir_of_sp sp, mp_of_kn kn in - let (sub,mbids,msid,objs) = substobjs in - let sub = subst_key subst sub in - let sub' = update_subst_alias subst sub in - let sub' = update_subst_alias sub' (map_msid msid mp) in - (* let sub = join_alias sub sub' in*) - let sub = join sub' sub in - let subst' = join sub subst in - (* substitutive_objects get the new substitution *) - let substobjs = (subst',mbids,msid,objs) in - (* if we are not a functor - calculate substitued. - We add "msid |-> mp" to the substitution *) - let substituted = subst_substobjs dir mp substobjs - in - (None,substobjs,substituted) - - -let classify_module (_,substobjs,_) = - Substitute (None,substobjs,None) + (None,(mbids,subst_mp subst mp, subst_objects subst objs)) +let classify_module (_,substobjs) = + Substitute (None,substobjs) let (in_module,out_module) = declare_object {(default_object "MODULE") with @@ -298,168 +230,6 @@ let (in_module,out_module) = subst_function = subst_module; classify_function = classify_module } - -let rec replace_alias modalias_obj obj = - let rec put_alias (id_alias,obj_alias) l = - match l with - [] -> [] - | (id,o)::r - when ( object_tag o = "MODULE") -> - if id = id_alias then -(* let (entry,subst_o,substed_o) = out_module_alias obj_alias in - let (entry',subst_o',substed_o') = out_module o in - begin - match substed_o,substed_o' with - Some a,Some b -> - (id,in_module_alias - (entry,subst_o',Some (dump_alias_object a b)))::r*) - (id_alias,obj_alias)::r - (* | _,_ -> (id,o)::r - end*) - else (id,o)::(put_alias (id_alias,obj_alias) r) - | e::r -> e::(put_alias (id_alias,obj_alias) r) in - let rec choose_obj_alias list_alias list_obj = - match list_alias with - | [] -> list_obj - | o::r ->choose_obj_alias r (put_alias o list_obj) in - choose_obj_alias modalias_obj obj - -and dump_alias_object alias_obj obj = - let rec alias_in_obj seg = - match seg with - | [] -> [] - | (id,o)::r when (object_tag o = "MODULE ALIAS") -> - (id,o)::(alias_in_obj r) - | e::r -> (alias_in_obj r) in - let modalias_obj = alias_in_obj alias_obj in - replace_alias modalias_obj obj - -and do_module_alias exists what iter_objects i dir mp alias substobjs objects = - let prefix = (dir,(alias,empty_dirpath)) in - let alias_objects = - try Some (MPmap.find alias !modtab_objects) with - Not_found -> None in - let dirinfo = DirModule (dir,(mp,empty_dirpath)) in - let vis = compute_visibility exists what i dir dirinfo in - Nametab.push_dir vis dir dirinfo; - modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; - match alias_objects,objects with - Some (_,seg), Some seg' -> - let new_seg = dump_alias_object seg seg' in - modtab_objects := MPmap.add mp (prefix,new_seg) !modtab_objects; - iter_objects (i+1) prefix new_seg - | _,_-> () - -and cache_module_alias ((sp,kn),(entry,substobjs,substituted)) = - let dir,mp,alias = match entry with - | None -> - anomaly "You must not recache interactive modules!" - | Some (me,sub_mte_o) -> - let sub_mtb_o = match sub_mte_o with - None -> None - | Some mte -> Some (Mod_typing.translate_struct_entry - (Global.env()) mte) - in - - let mp' = match me with - | {mod_entry_type = None; - mod_entry_expr = Some (MSEident mp)} -> - Global.add_alias (basename sp) mp - | _ -> anomaly "cache module alias" - in - if mp' <> mp_of_kn kn then - anomaly "Kernel and Library names do not match"; - - let _ = match sub_mtb_o with - None -> () - | Some (sub_mtb,sub) -> - check_subtypes mp' sub_mtb in - match me with - | {mod_entry_type = None; - mod_entry_expr = Some (MSEident mp)} -> - dir_of_sp sp,mp_of_kn kn,scrape_alias mp - | _ -> anomaly "cache module alias" - in - do_module_alias false "cache" load_objects 1 dir mp alias substobjs substituted - -and load_module_alias i ((sp,kn),(entry,substobjs,substituted)) = - let dir,mp,alias= - match entry with - | Some (me,_)-> - begin - match me with - |{mod_entry_type = None; - mod_entry_expr = Some (MSEident mp)} -> - dir_of_sp sp,mp_of_kn kn,scrape_alias mp - | _ -> anomaly "Modops: Not an alias" - end - | None -> anomaly "Modops: Empty info" - in - do_module_alias false "load" load_objects i dir mp alias substobjs substituted - -and open_module_alias i ((sp,kn),(entry,substobjs,substituted)) = - let dir,mp,alias= - match entry with - | Some (me,_)-> - begin - match me with - |{mod_entry_type = None; - mod_entry_expr = Some (MSEident mp)} -> - dir_of_sp sp,mp_of_kn kn,scrape_alias mp - | _ -> anomaly "Modops: Not an alias" - end - | None -> anomaly "Modops: Empty info" - in - do_module_alias true "open" open_objects i dir mp alias substobjs substituted - -and subst_module_alias ((sp,kn),subst,(entry,substobjs,_)) = - let dir,mp = dir_of_sp sp, mp_of_kn kn in - let (sub,mbids,msid,objs) = substobjs in - let sub' = update_subst_alias subst (map_msid msid mp) in - let subst' = join sub' subst in - let subst' = join sub subst' in - (* substitutive_objects get the new substitution *) - let substobjs = (subst',mbids,msid,objs) in - (* if we are not a functor - calculate substitued. - We add "msid |-> mp" to the substitution *) - match entry with - | Some (me,sub)-> - begin - match me with - |{mod_entry_type = None; - mod_entry_expr = Some (MSEident mp')} -> - let mp' = subst_mp subst' mp' in - let mp' = scrape_alias mp' in - (Some ({mod_entry_type = None; - mod_entry_expr = - Some (MSEident mp')},sub), - substobjs, match mbids with - | [] -> let subst = update_subst subst' (map_mp mp' mp) in - Some (subst_objects (dir,(mp',empty_dirpath)) - (join (join subst' subst) (join (map_msid msid mp') - (map_mp mp mp'))) - objs) - - | _ -> None) - - | _ -> anomaly "Modops: Not an alias" - end - | None -> anomaly "Modops: Empty info" - -and classify_module_alias (entry,substobjs,_) = - Substitute (entry,substobjs,None) - -let (in_module_alias,out_module_alias) = - declare_object {(default_object "MODULE ALIAS") with - cache_function = cache_module_alias; - open_function = open_module_alias; - classify_function = classify_module_alias; - subst_function = subst_module_alias; - load_function = load_module_alias } - - - - let cache_keep _ = anomaly "This module should not be cached!" let load_keep i ((sp,kn),seg) = @@ -553,9 +323,9 @@ let open_modtype i ((sp,kn),(entry,_)) = Nametab.push_modtype (Nametab.Exactly i) sp (mp_of_kn kn) -let subst_modtype (_,subst,(entry,(subs,mbids,msid,objs))) = +let subst_modtype (subst,(entry,(mbids,mp,objs))) = check_empty "subst_modtype" entry; - (entry,(join subs subst,mbids,msid,objs)) + (entry,(mbids,subst_mp subst mp,subst_objects subst objs)) let classify_modtype (_,substobjs) = @@ -571,147 +341,143 @@ let (in_modtype,_) = classify_function = classify_modtype } - -let rec replace_module_object idl (subst, mbids, msid, lib_stack) modobjs mp = - let rec mp_rec = function - | [] -> MPself msid - | i::r -> MPdot(mp_rec r,label_of_id i) - in - if mbids<>[] then +let rec replace_module_object idl ( mbids, mp, lib_stack) (mbids2,mp2,objs) mp1= + if mbids<>[] then error "Unexpected functor objects" - else - let rec replace_idl = function - | _,[] -> [] - | id::idl,(id',obj)::tail when id = id' -> - let tag = object_tag obj in - if tag = "MODULE" or tag ="MODULE ALIAS" then - (match idl with - [] -> (id, in_module_alias (Some - ({mod_entry_type = None; - mod_entry_expr = Some (MSEident mp)},None) - ,modobjs,None))::tail - | _ -> - let (a,substobjs,_) = if tag = "MODULE ALIAS" then - out_module_alias obj else out_module obj in - let substobjs' = replace_module_object idl substobjs modobjs mp in - if tag = "MODULE ALIAS" then - (id, in_module_alias (a,substobjs',None))::tail - else - (id, in_module (None,substobjs',None))::tail - ) - else error "MODULE expected!" - | idl,lobj::tail -> lobj::replace_idl (idl,tail) - in - (join (map_mp (mp_rec (List.rev idl)) mp) subst, mbids, msid, replace_idl (idl,lib_stack)) - -let abstract_substobjs mbids1 (subst, mbids2, msid, lib_stack) = - (subst, mbids1@mbids2, msid, lib_stack) - -let rec get_modtype_substobjs env = function - MSEident ln -> MPmap.find ln !modtypetab + else + let rec replace_idl = function + | _,[] -> [] + | id::idl,(id',obj)::tail when id = id' -> + if object_tag obj = "MODULE" then + (match idl with + [] -> (id, in_module + (None,(mbids,(MPdot(mp,label_of_id id)),subst_objects + (map_mp mp1 (MPdot(mp,label_of_id id)) empty_delta_resolver) objs)))::tail + | _ -> + let (_,substobjs) = out_module obj in + let substobjs' = replace_module_object idl substobjs + (mbids2,mp2,objs) mp in + (id, in_module (None,substobjs'))::tail + ) + else error "MODULE expected!" + | idl,lobj::tail -> lobj::replace_idl (idl,tail) + in + (mbids, mp, replace_idl (idl,lib_stack)) + +let discr_resolver mb = + match mb.mod_type with + SEBstruct _ -> + Some mb.mod_delta + | _ -> (*case mp is a functor *) + None + +(* Small function to avoid module typing during substobjs retrivial *) +let rec get_objs_modtype_application env = function +| MSEident mp -> + MPmap.find mp !modtypetab,Environ.lookup_modtype mp env,[] +| MSEapply (fexpr, MSEident mp) -> + let objs,mtb,mp_l= get_objs_modtype_application env fexpr in + objs,mtb,mp::mp_l +| MSEapply (_,mexpr) -> + Modops.error_application_to_not_path mexpr +| _ -> error "Application of a non-functor." + +let rec get_modtype_substobjs env mp_from= function + MSEident ln -> + MPmap.find ln !modtypetab | MSEfunctor (mbid,_,mte) -> - let (subst, mbids, msid, objs) = get_modtype_substobjs env mte in - (subst, mbid::mbids, msid, objs) - | MSEwith (mty, With_Definition _) -> get_modtype_substobjs env mty - | MSEwith (mty, With_Module (idl,mp)) -> - let substobjs = get_modtype_substobjs env mty in - let mp = Environ.scrape_alias mp env in - let modobjs = MPmap.find mp !modtab_substobjs in - replace_module_object idl substobjs modobjs mp - | MSEapply (mexpr, MSEident mp) -> - let ftb,sub1 = Mod_typing.translate_struct_entry env mexpr in - let farg_id, farg_b, fbody_b = Modops.destr_functor env - (Modops.eval_struct env ftb) in - let mp = Environ.scrape_alias mp env in - let sub_alias = (Environ.lookup_modtype mp env).typ_alias in - let sub_alias = match Modops.eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> join_alias - (subst_key (map_msid msid mp) sub_alias) - (map_msid msid mp) - | _ -> sub_alias in - let (subst, mbids, msid, objs) = get_modtype_substobjs env mexpr in - (match mbids with - | mbid::mbids -> - let resolve = - Modops.resolver_of_environment farg_id farg_b mp sub_alias env in - let sub3= - if sub1 = empty_subst then - update_subst sub_alias (map_mbid farg_id mp None) - else - let sub1' = join_alias sub1 (map_mbid farg_id mp None) in - let sub_alias' = update_subst sub_alias sub1' in - join sub1' sub_alias' - in - let sub3 = join sub3 (update_subst sub_alias (map_mbid farg_id mp None)) in - (* application outside the kernel, only for substitutive - objects (that are all non-logical objects) *) - ((join - (join subst sub3) - (map_mbid mbid mp (Some resolve))) - , mbids, msid, objs) - | [] -> match mexpr with - | MSEident _ -> error "Application of a non-functor" - | _ -> error "Application of a functor with too few arguments") + let (mbids, mp, objs) = get_modtype_substobjs env mp_from mte in + (mbid::mbids, mp, objs) + | MSEwith (mty, With_Definition _) -> get_modtype_substobjs env mp_from mty + | MSEwith (mty, With_Module (idl,mp1)) -> + let substobjs = get_modtype_substobjs env mp_from mty in + let modobjs = MPmap.find mp1 !modtab_substobjs in + replace_module_object idl substobjs modobjs mp1 + | MSEapply (fexpr, MSEident mp) -> + let (mbids, mp1, objs),mtb_mp1,mp_l = + get_objs_modtype_application env (MSEapply(fexpr, MSEident mp)) in + let rec compute_subst mbids sign mp_l = + match mbids,mp_l with + [],[] -> [],empty_subst + | mbid,[] -> mbid,empty_subst + | [],r -> error ("Application of a functor with too few arguments.") + | mbid::mbids,mp::mp_l -> + let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in + let mb = Environ.lookup_module mp env in + let mp_delta = discr_resolver mb in + let mbid_left,subst=compute_subst mbids fbody_b mp_l in + if mp_delta = None then + mbid_left,join (map_mbid mbid mp empty_delta_resolver) subst + else + let mp_delta = Modops.complete_inline_delta_resolver env mp + farg_id farg_b (Option.get mp_delta) in + mbid_left,join (map_mbid mbid mp mp_delta) subst + in + let mbids_left,subst = compute_subst mbids mtb_mp1.typ_expr (List.rev mp_l) in + (mbids_left, mp1,subst_objects subst objs) | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr - (* push names of bound modules (and their components) to Nametab *) (* add objects associated to them *) let process_module_bindings argids args = let process_arg id (mbid,mty) = let dir = make_dirpath [id] in let mp = MPbound mbid in - let substobjs = get_modtype_substobjs (Global.env()) mty in - ignore (do_load_and_subst_module 1 dir mp substobjs []) - in - List.iter2 process_arg argids args - + let (mbids,mp_from,objs) = get_modtype_substobjs (Global.env()) mp mty in + let substobjs = (mbids,mp,subst_objects + (map_mp mp_from mp empty_delta_resolver) objs)in + do_module false "start" load_objects 1 dir mp substobjs [] + in + List.iter2 process_arg argids args + let intern_args interp_modtype (idl,arg) = let lib_dir = Lib.library_dp() in let mbids = List.map (fun (_,id) -> make_mbid lib_dir (string_of_id id)) idl in let mty = interp_modtype (Global.env()) arg in let dirs = List.map (fun (_,id) -> make_dirpath [id]) idl in - let substobjs = get_modtype_substobjs (Global.env()) mty in + let (mbi,mp_from,objs) = get_modtype_substobjs (Global.env()) + (MPbound (List.hd mbids)) mty in List.map2 (fun dir mbid -> - Global.add_module_parameter mbid mty; - let mp = MPbound mbid in - ignore (do_load_and_subst_module 1 dir mp substobjs []); - (mbid,mty)) + let resolver = Global.add_module_parameter mbid mty in + let mp = MPbound mbid in + let substobjs = (mbi,mp,subst_objects + (map_mp mp_from mp resolver) objs) in + do_module false "interp" load_objects 1 dir mp substobjs []; + (mbid,mty)) dirs mbids let start_module interp_modtype export id args res_o = let fs = Summary.freeze_summaries () in - let mp = Global.start_module id in let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in - let res_entry_o, sub_body_o = match res_o with None -> None, None | Some (res, restricted) -> (* we translate the module here to catch errors as early as possible *) let mte = interp_modtype (Global.env()) res in - if restricted then - Some mte, None - else - let mtb,_ = Mod_typing.translate_struct_entry (Global.env()) mte in - let sub_mtb = - List.fold_right - (fun (arg_id,arg_t) mte -> - let arg_t,sub = Mod_typing.translate_struct_entry (Global.env()) arg_t + if restricted then + let _ = Mod_typing.translate_struct_type_entry (Global.env()) mte in + Some mte, None + else + let mtb = Mod_typing.translate_module_type (Global.env()) + mp mte in + let funct_mtb = + List.fold_right + (fun (arg_id,arg_t) mte -> + let arg_t = Mod_typing.translate_module_type (Global.env()) + (MPbound arg_id) arg_t in - let arg_t = {typ_expr = arg_t; - typ_strength = None; - typ_alias = sub} in SEBfunctor(arg_id,arg_t,mte)) - arg_entries mtb - in - None, Some sub_mtb + arg_entries mtb.typ_expr + in + None, Some {mtb with + typ_expr = funct_mtb} in let mbids = List.map fst arg_entries in - openmod_info:=(mbids,res_entry_o,sub_body_o); + openmod_info:=(mp,mbids,res_entry_o,sub_body_o); let prefix = Lib.start_module export id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); Lib.add_frozen_state (); mp @@ -720,24 +486,25 @@ let start_module interp_modtype export id args res_o = let end_module () = let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in - let mbids, res_o, sub_o = !openmod_info in + let mp,mbids, res_o, sub_o = !openmod_info in let substitute, keep, special = Lib.classify_segment lib_stack in - let dir = fst oldprefix in - let msid = msid_of_prefix oldprefix in - - let substobjs, keep, special = try + let mp_from,substobjs, keep, special = try match res_o with | None -> - (empty_subst, mbids, msid, substitute), keep, special - | Some (MSEident ln) -> - abstract_substobjs mbids (MPmap.find ln (!modtypetab)), [], [] + (* the module is not sealed *) + None,( mbids, mp, substitute), keep, special + | Some (MSEident ln as mty) -> + let (mbids1,mp1,objs) = get_modtype_substobjs (Global.env()) mp mty in + Some mp1,(mbids@mbids1,mp1,objs), [], [] | Some (MSEwith _ as mty) -> - abstract_substobjs mbids (get_modtype_substobjs (Global.env()) mty), [], [] + let (mbids1,mp1,objs) = get_modtype_substobjs (Global.env()) mp mty in + Some mp1,(mbids@mbids1,mp1,objs), [], [] | Some (MSEfunctor _) -> anomaly "Funsig cannot be here..." | Some (MSEapply _ as mty) -> - abstract_substobjs mbids (get_modtype_substobjs (Global.env()) mty), [], [] + let (mbids1,mp1,objs) = get_modtype_substobjs (Global.env()) mp mty in + Some mp1,(mbids@mbids1,mp1,objs), [], [] with Not_found -> anomaly "Module objects not found..." in @@ -745,15 +512,21 @@ let end_module () = dependencies on functor arguments *) let id = basename (fst oldoname) in - let mp = Global.end_module fs id res_o in + let mp,resolver = Global.end_module fs id res_o in begin match sub_o with None -> () | Some sub_mtb -> check_subtypes mp sub_mtb end; - let substituted = subst_substobjs dir mp substobjs in - let node = in_module (None,substobjs,substituted) in +(* we substitute objects if the module is + sealed by a signature (ie. mp_from != None *) + let substobjs = match mp_from,substobjs with + None,_ -> substobjs + | Some mp_from,(mbids,_,objs) -> + (mbids,mp,subst_objects (map_mp mp_from mp resolver) objs) + in + let node = in_module (None,substobjs) in let objects = if keep = [] || mbids <> [] then special@[node] (* no keep objects or we are defining a functor *) @@ -785,28 +558,30 @@ type library_name = dir_path (* The first two will form substitutive_objects, the last one is keep *) type library_objects = - mod_self_id * lib_objects * lib_objects + module_path * lib_objects * lib_objects let register_library dir cenv objs digest = let mp = MPfile dir in - try + let substobjs, keep = + try ignore(Global.lookup_module mp); (* if it's in the environment, the cached objects should be correct *) - let substobjs, objects = Dirmap.find dir !library_cache in - do_module false "register_library" load_objects 1 dir mp substobjs objects + Dirmap.find dir !library_cache with Not_found -> if mp <> Global.import cenv digest then anomaly "Unexpected disk module name"; - let msid,substitute,keep = objs in - let substobjs = empty_subst, [], msid, substitute in - let objects = do_load_and_subst_module 1 dir mp substobjs keep in - let modobjs = substobjs, objects in - library_cache := Dirmap.add dir modobjs !library_cache + let mp,substitute,keep = objs in + let substobjs = [], mp, substitute in + let modobjs = substobjs, keep in + library_cache := Dirmap.add dir modobjs !library_cache; + modobjs + in + do_module false "register_library" load_objects 1 dir mp substobjs keep let start_library dir = let mp = Global.start_library dir in - openmod_info:=[],None,None; + openmod_info:=mp,[],None,None; Lib.start_compilation dir mp; Lib.add_frozen_state () @@ -816,10 +591,9 @@ let set_end_library_hook f = end_library_hook := f let end_library dir = !end_library_hook(); let prefix, lib_stack = Lib.end_compilation dir in - let cenv = Global.export dir in - let msid = msid_of_prefix prefix in + let mp,cenv = Global.export dir in let substitute, keep, _ = Lib.classify_segment lib_stack in - cenv,(msid,substitute,keep) + cenv,(mp,substitute,keep) (* implementation of Export M and Import M *) @@ -838,8 +612,8 @@ let cache_import (_,(_,mp)) = let classify_import (export,_ as obj) = if export then Substitute obj else Dispose -let subst_import (_,subst,(export,mp as obj)) = - let mp' = subst_mp subst mp in +let subst_import (subst,(export,mp as obj)) = + let mp' = subst_mp subst mp in if mp'==mp then obj else (export,mp') @@ -870,27 +644,23 @@ let start_modtype interp_modtype id args = let end_modtype () = - let oldoname,prefix,fs,lib_stack = Lib.end_modtype () in let id = basename (fst oldoname) in let substitute, _, special = Lib.classify_segment lib_stack in - - let msid = msid_of_prefix prefix in let mbids = !openmodtype_info in - let modtypeobjs = empty_subst, mbids, msid, substitute in - - let ln = Global.end_modtype fs id in + let mp = Global.end_modtype fs id in + let modtypeobjs = mbids, mp, substitute in let oname = Lib.add_leaves id (special@[in_modtype (None, modtypeobjs)]) in if fst oname <> fst oldoname then anomaly "Section paths generated on start_ and end_modtype do not match"; - if (mp_of_kn (snd oname)) <> ln then + if (mp_of_kn (snd oname)) <> mp then anomaly "Kernel and Library names do not match"; Lib.add_frozen_state ()(* to prevent recaching *); - ln + mp let declare_modtype interp_modtype id args mty = @@ -907,64 +677,79 @@ let declare_modtype interp_modtype id args mty = arg_entries base_mty in - let substobjs = get_modtype_substobjs (Global.env()) entry in - (* Undo the simulated interactive building of the module type *) - (* and declare the module type as a whole *) - Summary.unfreeze_summaries fs; + let (mbids,mp_from,objs) = get_modtype_substobjs (Global.env()) mmp entry in + (* Undo the simulated interactive building of the module type *) + (* and declare the module type as a whole *) - ignore (add_leaf id (in_modtype (Some entry, substobjs))); - mmp + let substobjs = (mbids,mmp, + subst_objects (map_mp mp_from mmp empty_delta_resolver) objs) in + Summary.unfreeze_summaries fs; + ignore (add_leaf id (in_modtype (Some entry, substobjs))); + mmp with e -> (* Something wrong: undo the whole process *) Summary.unfreeze_summaries fs; raise e +(* Small function to avoid module typing during substobjs retrivial *) +let rec get_objs_module_application env = function +| MSEident mp -> + MPmap.find mp !modtab_substobjs,Environ.lookup_module mp env,[] +| MSEapply (fexpr, MSEident mp) -> + let objs,mtb,mp_l= get_objs_module_application env fexpr in + objs,mtb,mp::mp_l +| MSEapply (_,mexpr) -> + Modops.error_application_to_not_path mexpr +| _ -> error "Application of a non-functor." -let rec get_module_substobjs env = function + +let rec get_module_substobjs env mp_from = function | MSEident mp -> MPmap.find mp !modtab_substobjs | MSEfunctor (mbid,mty,mexpr) -> - let (subst, mbids, msid, objs) = get_module_substobjs env mexpr in - (subst, mbid::mbids, msid, objs) - | MSEapply (mexpr, MSEident mp) -> - let ftb,sub1 = Mod_typing.translate_struct_entry env mexpr in - let farg_id, farg_b, fbody_b = Modops.destr_functor env - (Modops.eval_struct env ftb) in - let mp = Environ.scrape_alias mp env in - let sub_alias = (Environ.lookup_modtype mp env).typ_alias in - let sub_alias = match Modops.eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> join_alias - (subst_key (map_msid msid mp) sub_alias) - (map_msid msid mp) - | _ -> sub_alias in - let (subst, mbids, msid, objs) = get_module_substobjs env mexpr in + let (mbids, mp, objs) = get_module_substobjs env mp_from mexpr in + (mbid::mbids, mp, objs) + | MSEapply (fexpr, MSEident mp) -> + let (mbids, mp1, objs),mb_mp1,mp_l = + get_objs_module_application env (MSEapply(fexpr, MSEident mp)) in + let rec compute_subst mbids sign mp_l = + match mbids,mp_l with + [],[] -> [],empty_subst + | mbid,[] -> mbid,empty_subst + | [],r -> error ("Application of a functor with too few arguments.") + | mbid::mbids,mp::mp_l -> + let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in + let mb = Environ.lookup_module mp env in + let mp_delta = discr_resolver mb in + let mbid_left,subst=compute_subst mbids fbody_b mp_l in + if mp_delta = None then + mbid_left,join (map_mbid mbid mp empty_delta_resolver) subst + else + let mp_delta = Modops.complete_inline_delta_resolver env mp + farg_id farg_b (Option.get mp_delta) in + mbid_left,join (map_mbid mbid mp mp_delta) subst + in + let mbids_left,subst = compute_subst mbids mb_mp1.mod_type (List.rev mp_l) in + (mbids_left, mp1,subst_objects subst objs) + (* let sign,alg,equiv,_ = Mod_typing.translate_struct_module_entry env mp_from fexpr in + let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in + let mb = Environ.lookup_module mp env in + let mp_delta = discr_resolver mb in + let (mbids, mp1, objs) = get_module_substobjs env mp_from fexpr in (match mbids with | mbid::mbids -> - let resolve = - Modops.resolver_of_environment farg_id farg_b mp sub_alias env in - let sub3= - if sub1 = empty_subst then - update_subst sub_alias (map_mbid farg_id mp None) - else - let sub1' = join_alias sub1 (map_mbid farg_id mp None) in - let sub_alias' = update_subst sub_alias sub1' in - join sub1' sub_alias' - in - let sub3 = join sub3 (update_subst sub_alias (map_mbid farg_id mp None)) in - (* application outside the kernel, only for substitutive - objects (that are all non-logical objects) *) - ((join - (join subst sub3) - (map_mbid mbid mp (Some resolve))) - , mbids, msid, objs) - | [] -> match mexpr with + if mp_delta = None then + (mbids, mp1,subst_objects (map_mbid mbid mp empty_delta_resolver) objs) + else + let mp_delta = Modops.complete_inline_delta_resolver env mp + farg_id farg_b (Option.get mp_delta) in + (mbids, mp1,subst_objects (map_mbid mbid mp mp_delta) objs) + | [] -> match fexpr with | MSEident _ -> error "Application of a non-functor." - | _ -> error "Application of a functor with too few arguments.") + | _ -> error "Application of a functor with too few arguments.")*) | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr - | MSEwith (mty, With_Definition _) -> get_module_substobjs env mty - | MSEwith (mty, With_Module (idl,mp)) -> - let substobjs = get_module_substobjs env mty in - let modobjs = MPmap.find mp !modtab_substobjs in - replace_module_object idl substobjs modobjs mp + | MSEwith (mty, With_Definition _) -> get_module_substobjs env mp_from mty + | MSEwith (mty, With_Module (idl,mp)) -> assert false + (* Include *) @@ -991,46 +776,32 @@ let lift_oname (sp,kn) = let dir,_ = Libnames.repr_path sp in (dir,mp) -let cache_include (oname,((me,is_mod),substobjs,substituted)) = +let cache_include (oname,((me,is_mod),(mbis,mp1,objs))) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in - Global.add_include me; - match substituted with - Some seg -> - load_objects 1 prefix seg; - open_objects 1 prefix seg; - | None -> () - -let load_include i (oname,((me,is_mod),substobjs,substituted)) = + load_objects 1 prefix objs; + open_objects 1 prefix objs + +let load_include i (oname,((me,is_mod),(mbis,mp1,objs))) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in - match substituted with - Some seg -> - load_objects i prefix seg - | None -> () - -let open_include i (oname,((me,is_mod),substobjs,substituted)) = + load_objects i prefix objs + + +let open_include i (oname,((me,is_mod),(mbis,mp1,objs))) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in - match substituted with - Some seg -> - if is_mod then - open_objects i prefix seg - else - if i = 1 then - open_objects i prefix seg - | None -> () - -let subst_include (oname,subst,((me,is_mod),substobj,_)) = - let dir,mp1 = lift_oname oname in - let (sub,mbids,msid,objs) = substobj in - let subst' = join sub subst in - let substobjs = (subst',mbids,msid,objs) in - let substituted = subst_substobjs dir mp1 substobjs in - ((subst_inc_expr subst' me,is_mod),substobjs,substituted) - -let classify_include ((me,is_mod),substobjs,_) = - Substitute ((me,is_mod),substobjs,None) + if is_mod || i = 1 then + open_objects i prefix objs + else () + +let subst_include (subst,((me,is_mod),substobj)) = + let (mbids,mp,objs) = substobj in + let substobjs = (mbids,subst_mp subst mp,subst_objects subst objs) in + ((subst_inc_expr subst me,is_mod),substobjs) + +let classify_include ((me,is_mod),substobjs) = + Substitute ((me,is_mod),substobjs) let (in_include,out_include) = declare_object {(default_object "INCLUDE") with @@ -1040,20 +811,19 @@ let (in_include,out_include) = subst_function = subst_include; classify_function = classify_include } -let rec update_include (sub,mbids,msid,objs) = +let rec update_include (mbids,mp,objs) = let rec replace_include = function | [] -> [] | (id,obj)::tail -> if object_tag obj = "INCLUDE" then - let ((me,is_mod),substobjs,substituted) = out_include obj in + let ((me,is_mod),substobjs) = out_include obj in let substobjs' = update_include substobjs in - (id, in_include ((me,true),substobjs',substituted)):: + (id, in_include ((me,true),substobjs')):: (replace_include tail) else (id,obj)::(replace_include tail) in - (sub,mbids,msid,replace_include objs) - + (mbids,mp,replace_include objs) let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o = @@ -1084,8 +854,7 @@ let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o = Some (List.fold_right (fun (mbid,mte) me -> MSEfunctor(mbid,mte,me)) arg_entries - (interp_modexpr (Global.env()) mexpr)) - in + (interp_modexpr (Global.env()) mexpr)) in let entry = {mod_entry_type = mty_entry_o; mod_entry_expr = mexpr_entry_o } @@ -1093,45 +862,33 @@ let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o = let env = Global.env() in let substobjs = match entry with - | {mod_entry_type = Some mte} -> get_modtype_substobjs env mte - | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mexpr + | {mod_entry_type = Some mte} -> get_modtype_substobjs env mmp mte + | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mmp mexpr | _ -> anomaly "declare_module: No type, no body ..." in - let substobjs = update_include substobjs in + let (mbids,mp_from,objs) = update_include substobjs in (* Undo the simulated interactive building of the module *) (* and declare the module as a whole *) Summary.unfreeze_summaries fs; - match entry with - |{mod_entry_type = None; - mod_entry_expr = Some (MSEident mp) } -> - let dir,mp' = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in - let (sub,mbids,msid,objs) = substobjs in - let mp1 = Environ.scrape_alias mp env in - let prefix = dir,(mp1,empty_dirpath) in - let substituted = - match mbids with - | [] -> - Some (subst_objects prefix - (join sub (join (map_msid msid mp1) (map_mp mp' mp1))) objs) - | _ -> None in - ignore (add_leaf - id - (in_module_alias (Some ({mod_entry_type = None; - mod_entry_expr = Some (MSEident mp1) }, mty_sub_o), - substobjs, substituted))); - mmp - | _ -> - let dir,mp = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in - let (sub,mbids,msid,objs) = substobjs in - let sub' = join_alias (subst_key (map_msid msid mp) sub) (map_msid msid mp) in - let substobjs = ( sub',mbids,msid,objs) in - let substituted = subst_substobjs dir mp substobjs in - ignore (add_leaf - id - (in_module (Some (entry, mty_sub_o), substobjs, substituted))); - mmp - - with e -> + let dir,mp = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in + let mp_env,resolver = Global.add_module id entry in + let _ = if mp_env <> mp then + anomaly "Kernel and Library names do not match"; + match mty_sub_o with + | None -> () + | Some sub_mte -> + let sub_mtb = Mod_typing.translate_module_type + env mp sub_mte in + check_subtypes mp_env sub_mtb + in + let substobjs = (mbids,mp_env, + subst_objects(map_mp mp_from mp_env resolver) objs) in + ignore (add_leaf + id + (in_module (Some (entry, mty_sub_o), substobjs))); + mmp + + with e -> (* Something wrong: undo the whole process *) Summary.unfreeze_summaries fs; raise e @@ -1142,19 +899,19 @@ let declare_include interp_struct me_ast is_mod = try let env = Global.env() in - let me = interp_struct env me_ast in - let substobjs = + let me = interp_struct env me_ast in + let mp1,_ = current_prefix () in + let (mbids,mp,objs)= if is_mod then - get_module_substobjs env me + get_module_substobjs env mp1 me else - get_modtype_substobjs env me in - let mp1,_ = current_prefix () in - let dir = dir_of_sp (Lib.path_of_include()) in - let substituted = subst_substobjs dir mp1 substobjs in + get_modtype_substobjs env mp1 me in let id = current_mod_id() in - + let resolver = Global.add_include me is_mod in + let substobjs = (mbids,mp1, + subst_objects (map_mp mp mp1 resolver) objs) in ignore (add_leaf id - (in_include ((me,is_mod), substobjs, substituted))) + (in_include ((me,is_mod), substobjs))) with e -> (* Something wrong: undo the whole process *) Summary.unfreeze_summaries fs; raise e diff --git a/library/global.ml b/library/global.ml index e228de23a..6d7942ec0 100644 --- a/library/global.ml +++ b/library/global.ml @@ -48,14 +48,6 @@ let push_named_def d = global_env := env; cst -(*let add_thing add kn thing = - let _,dir,l = repr_kn kn in - let kn',newenv = add dir l thing !global_env in - if kn = kn' then - global_env := newenv - else - anomaly "Kernel names do not match." -*) let add_thing add dir id thing = let kn, newenv = add dir (label_of_id id) thing !global_env in @@ -65,14 +57,23 @@ let add_thing add dir id thing = let add_constant = add_thing add_constant let add_mind = add_thing add_mind let add_modtype = add_thing (fun _ -> add_modtype) () -let add_module = add_thing (fun _ -> add_module) () -let add_alias = add_thing (fun _ -> add_alias) () + + +let add_module id me = + let l = label_of_id id in + let mp,resolve,new_env = add_module l me !global_env in + global_env := new_env; + mp,resolve + let add_constraints c = global_env := add_constraints c !global_env let set_engagement c = global_env := set_engagement c !global_env -let add_include me = global_env := add_include me !global_env +let add_include me is_module = + let resolve,newenv = add_include me is_module !global_env in + global_env := newenv; + resolve let start_module id = let l = label_of_id id in @@ -82,15 +83,16 @@ let start_module id = let end_module fs id mtyo = let l = label_of_id id in - let mp,newenv = end_module l mtyo !global_env in + let mp,resolve,newenv = end_module l mtyo !global_env in Summary.unfreeze_summaries fs; global_env := newenv; - mp + mp,resolve let add_module_parameter mbid mte = - let newenv = add_module_parameter mbid mte !global_env in - global_env := newenv + let resolve,newenv = add_module_parameter mbid mte !global_env in + global_env := newenv; + resolve let start_modtype id = @@ -117,15 +119,22 @@ let lookup_mind kn = lookup_mind kn (env()) let lookup_module mp = lookup_module mp (env()) let lookup_modtype kn = lookup_modtype kn (env()) +let constant_of_delta con = + let resolver,resolver_param = (delta_of_senv !global_env) in + Mod_subst.constant_of_delta resolver_param + (Mod_subst.constant_of_delta resolver con) - - +let mind_of_delta mind = + let resolver,resolver_param = (delta_of_senv !global_env) in + Mod_subst.mind_of_delta resolver_param + (Mod_subst.mind_of_delta resolver mind) + let start_library dir = let mp,newenv = start_library dir !global_env in global_env := newenv; mp -let export s = snd (export !global_env s) +let export s = export !global_env s let import cenv digest = let mp,newenv = import cenv digest !global_env in @@ -161,3 +170,5 @@ let register field value by_clause = let entry = kind_of_term value in let senv = Safe_typing.register !global_env field entry by_clause in global_env := senv + + diff --git a/library/global.mli b/library/global.mli index 3c2317122..30bd04150 100644 --- a/library/global.mli +++ b/library/global.mli @@ -15,6 +15,7 @@ open Term open Declarations open Entries open Indtypes +open Mod_subst open Safe_typing (*i*) @@ -47,12 +48,11 @@ val push_named_def : (identifier * constr * types option) -> Univ.constraints val add_constant : dir_path -> identifier -> global_declaration -> constant val add_mind : - dir_path -> identifier -> mutual_inductive_entry -> kernel_name + dir_path -> identifier -> mutual_inductive_entry -> mutual_inductive -val add_module : identifier -> module_entry -> module_path +val add_module : identifier -> module_entry -> module_path * delta_resolver val add_modtype : identifier -> module_struct_entry -> module_path -val add_include : module_struct_entry -> unit -val add_alias : identifier -> module_path -> module_path +val add_include : module_struct_entry -> bool -> delta_resolver val add_constraints : constraints -> unit @@ -66,10 +66,11 @@ val set_engagement : engagement -> unit of the started module / module type *) val start_module : identifier -> module_path -val end_module : - Summary.frozen -> identifier -> module_struct_entry option -> module_path -val add_module_parameter : mod_bound_id -> module_struct_entry -> unit +val end_module : Summary.frozen ->identifier -> module_struct_entry option -> + module_path * delta_resolver + +val add_module_parameter : mod_bound_id -> module_struct_entry -> delta_resolver val start_modtype : identifier -> module_path val end_modtype : Summary.frozen -> identifier -> module_path @@ -83,10 +84,12 @@ val lookup_inductive : inductive -> mutual_inductive_body * one_inductive_body val lookup_mind : mutual_inductive -> mutual_inductive_body val lookup_module : module_path -> module_body val lookup_modtype : module_path -> module_type_body +val constant_of_delta : constant -> constant +val mind_of_delta : mutual_inductive -> mutual_inductive (* Compiled modules *) val start_library : dir_path -> module_path -val export : dir_path -> compiled_library +val export : dir_path -> module_path * compiled_library val import : compiled_library -> Digest.t -> module_path (*s Function to get an environment from the constants part of the global diff --git a/library/goptions.ml b/library/goptions.ml index 032016c3d..06d4b618e 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -91,7 +91,7 @@ module MakeTable = | GOadd -> t := MySet.add p !t | GOrmv -> t := MySet.remove p !t in let load_options i o = if i=1 then cache_options o in - let subst_options (_,subst,(f,p as obj)) = + let subst_options (subst,(f,p as obj)) = let p' = A.subst subst p in if p' == p then obj else (f,p') diff --git a/library/heads.ml b/library/heads.ml index 150ba8942..056f78a5f 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -39,8 +39,20 @@ type head_approximation = (** Registration as global tables and rollback. *) +module Evalreford = struct + type t = evaluable_global_reference + let compare x y = + let make_name = function + | EvalConstRef con -> + EvalConstRef(constant_of_kn(canonical_con con)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) +end + module Evalrefmap = - Map.Make (struct type t = evaluable_global_reference let compare = compare end) + Map.Make (Evalreford) + let head_map = ref Evalrefmap.empty @@ -144,7 +156,7 @@ let subst_head_approximation subst = function kind_of_head (Global.env()) c | x -> x -let subst_head (_,subst,(ref,k)) = +let subst_head (subst,(ref,k)) = (subst_evaluable_reference subst ref, subst_head_approximation subst k) let discharge_head (_,(ref,k)) = diff --git a/library/impargs.ml b/library/impargs.ml index d27ced220..1edac69aa 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -435,7 +435,7 @@ type implicit_interactive_request = type implicit_discharge_request = | ImplLocal | ImplConstant of constant * implicits_flags - | ImplMutualInductive of kernel_name * implicits_flags + | ImplMutualInductive of mutual_inductive * implicits_flags | ImplInteractive of global_reference * implicits_flags * implicit_interactive_request @@ -455,7 +455,7 @@ let cache_implicits o = let subst_implicits_decl subst (r,imps as o) = let r' = fst (subst_global subst r) in if r==r' then o else (r',imps) -let subst_implicits (_,subst,(req,l)) = +let subst_implicits (subst,(req,l)) = (ImplLocal,list_smartmap (subst_implicits_decl subst) l) let impls_of_context ctx = diff --git a/library/impargs.mli b/library/impargs.mli index 6d2b01e8f..e8191e863 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -108,7 +108,7 @@ type implicit_interactive_request = type implicit_discharge_request = | ImplLocal | ImplConstant of constant * implicits_flags - | ImplMutualInductive of kernel_name * implicits_flags + | ImplMutualInductive of mutual_inductive * implicits_flags | ImplInteractive of global_reference * implicits_flags * implicit_interactive_request diff --git a/library/lib.ml b/library/lib.ml index 961a4ebb9..b8dcee9d2 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -37,21 +37,21 @@ let iter_objects f i prefix = let load_objects = iter_objects load_object let open_objects = iter_objects open_object -let subst_objects prefix subst seg = +let subst_objects subst seg = let subst_one = fun (id,obj as node) -> - let obj' = subst_object (make_oname prefix id, subst, obj) in + let obj' = subst_object (subst,obj) in if obj' == obj then node else (id, obj') in list_smartmap subst_one seg -let load_and_subst_objects i prefix subst seg = +(*let load_and_subst_objects i prefix subst seg = List.rev (List.fold_left (fun seg (id,obj as node) -> let obj' = subst_object (make_oname prefix id, subst, obj) in let node = if obj == obj' then node else (id, obj') in load_object i (make_oname prefix id, obj'); node :: seg) [] seg) - +*) let classify_segment seg = let rec clean ((substl,keepl,anticipl) as acc) = function | (_,CompilingLibrary _) :: _ | [] -> acc @@ -435,13 +435,13 @@ type binding_kind = Explicit | Implicit type variable_info = Names.identifier * binding_kind * Term.constr option * Term.types type variable_context = variable_info list -type abstr_list = variable_context Names.Cmap.t * variable_context Names.KNmap.t +type abstr_list = variable_context Names.Cmap.t * variable_context Names.Mindmap.t let sectab = ref ([] : ((Names.identifier * binding_kind) list * Cooking.work_list * abstr_list) list) let add_section () = - sectab := ([],(Names.Cmap.empty,Names.KNmap.empty),(Names.Cmap.empty,Names.KNmap.empty)) :: !sectab + sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty),(Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab let add_section_variable id impl = match !sectab with @@ -474,7 +474,7 @@ let add_section_replacement f g hyps = sectab := (vars,f args exps,g sechyps abs)::sl let add_section_kn kn = - let f x (l1,l2) = (l1,Names.KNmap.add kn x l2) in + let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in add_section_replacement f f let add_section_constant kn = @@ -489,7 +489,7 @@ let section_segment_of_constant con = Names.Cmap.find con (fst (pi3 (List.hd !sectab))) let section_segment_of_mutual_inductive kn = - Names.KNmap.find kn (snd (pi3 (List.hd !sectab))) + Names.Mindmap.find kn (snd (pi3 (List.hd !sectab))) let rec list_mem_assoc x = function | [] -> raise Not_found @@ -502,7 +502,7 @@ let section_instance = function | ConstRef con -> Names.Cmap.find con (fst (pi2 (List.hd !sectab))) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - Names.KNmap.find kn (snd (pi2 (List.hd !sectab))) + Names.Mindmap.find kn (snd (pi2 (List.hd !sectab))) let is_in_section ref = try ignore (section_instance ref); true with Not_found -> false @@ -772,7 +772,7 @@ let mp_of_global ref = let rec dp_of_mp modp = match modp with | Names.MPfile dp -> dp - | Names.MPbound _ | Names.MPself _ -> library_dp () + | Names.MPbound _ -> library_dp () | Names.MPdot (mp,_) -> dp_of_mp mp let rec split_mp mp = @@ -781,7 +781,6 @@ let rec split_mp mp = | Names.MPdot (prfx, lbl) -> let mprec, dprec = split_mp prfx in mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec)) - | Names.MPself msid -> let (_, id, dp) = Names.repr_msid msid in library_dp(), Names.make_dirpath [Names.id_of_string id] | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in library_dp(), Names.make_dirpath [Names.id_of_string id] let split_modpath mp = @@ -789,7 +788,6 @@ let split_modpath mp = | Names.MPfile dp -> dp, [] | Names.MPbound mbid -> library_dp (), [Names.id_of_mbid mbid] - | Names.MPself msid -> library_dp (), [Names.id_of_msid msid] | Names.MPdot (mp,l) -> let (mp', lab) = aux mp in (mp', Names.id_of_label l :: lab) in @@ -819,8 +817,8 @@ let remove_section_part ref = (* Discharging names *) let pop_kn kn = - let (mp,dir,l) = Names.repr_kn kn in - Names.make_kn mp (pop_dirpath dir) l + let (mp,dir,l) = Names.repr_mind kn in + Names.make_mind mp (pop_dirpath dir) l let pop_con con = let (mp,dir,l) = Names.repr_con con in @@ -831,7 +829,7 @@ let con_defined_in_sec kn = dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) let defined_in_sec kn = - let _,dir,_ = Names.repr_kn kn in + let _,dir,_ = Names.repr_mind kn in dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) let discharge_global = function diff --git a/library/lib.mli b/library/lib.mli index 0e2e304cd..32d1c0009 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -32,8 +32,8 @@ type lib_objects = (Names.identifier * Libobject.obj) list val open_objects : int -> Libnames.object_prefix -> lib_objects -> unit val load_objects : int -> Libnames.object_prefix -> lib_objects -> unit -val subst_objects : Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects -val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects +val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects +(*val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) (* [classify_segment seg] verifies that there are no OpenedThings, clears ClosedSections and FrozenStates and divides Leafs according @@ -183,13 +183,13 @@ val is_in_section : Libnames.global_reference -> bool val add_section_variable : Names.identifier -> binding_kind -> unit val add_section_constant : Names.constant -> Sign.named_context -> unit -val add_section_kn : Names.kernel_name -> Sign.named_context -> unit +val add_section_kn : Names.mutual_inductive -> Sign.named_context -> unit val replacement_context : unit -> - (Names.identifier array Names.Cmap.t * Names.identifier array Names.KNmap.t) + (Names.identifier array Names.Cmap.t * Names.identifier array Names.Mindmap.t) (*s Discharge: decrease the section level if in the current section *) -val discharge_kn : Names.kernel_name -> Names.kernel_name +val discharge_kn : Names.mutual_inductive -> Names.mutual_inductive val discharge_con : Names.constant -> Names.constant val discharge_global : Libnames.global_reference -> Libnames.global_reference val discharge_inductive : Names.inductive -> Names.inductive diff --git a/library/libnames.ml b/library/libnames.ml index 2b335ea6c..fad0336fc 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -27,13 +27,21 @@ let isConstRef = function ConstRef _ -> true | _ -> false let isIndRef = function IndRef _ -> true | _ -> false let isConstructRef = function ConstructRef _ -> true | _ -> false +let eq_gr gr1 gr2 = + match gr1,gr2 with + ConstRef con1, ConstRef con2 -> + eq_constant con1 con2 + | IndRef kn1,IndRef kn2 -> eq_ind kn1 kn2 + | ConstructRef kn1,ConstructRef kn2 -> eq_constructor kn1 kn2 + | _,_ -> gr1=gr2 + let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef" let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" let subst_constructor subst ((kn,i),j as ref) = - let kn' = subst_kn subst kn in + let kn' = subst_ind subst kn in if kn==kn' then ref, mkConstruct ref else ((kn',i),j), mkConstruct ((kn',i),j) @@ -43,7 +51,7 @@ let subst_global subst ref = match ref with let kn',t = subst_con subst kn in if kn==kn' then ref, mkConst kn else ConstRef kn', t | IndRef (kn,i) -> - let kn' = subst_kn subst kn in + let kn' = subst_ind subst kn in if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i) | ConstructRef ((kn,i),j as c) -> let c',t = subst_constructor subst c in @@ -65,15 +73,25 @@ let constr_of_global = function let constr_of_reference = constr_of_global let reference_of_constr = global_of_constr -module RefOrdered = - struct - type t = global_reference - let compare = Pervasives.compare - end - +(* outside of the kernel, names are ordered on their canonical part *) +module RefOrdered = struct + type t = global_reference + let compare x y = + let make_name = function + | ConstRef con -> + ConstRef(constant_of_kn(canonical_con con)) + | IndRef (kn,i) -> + IndRef(mind_of_kn(canonical_mind kn),i) + | ConstructRef ((kn,i),j )-> + ConstructRef((mind_of_kn(canonical_mind kn),i),j) + | VarRef id -> VarRef id + in + Pervasives.compare (make_name x) (make_name y) +end + module Refset = Set.Make(RefOrdered) module Refmap = Map.Make(RefOrdered) - + (* Extended global references *) type syndef_name = kernel_name @@ -191,26 +209,22 @@ let restrict_path n sp = let dir' = list_firstn n (repr_dirpath dir) in make_path (make_dirpath dir') s -let encode_kn dir id = make_kn (MPfile dir) empty_dirpath (label_of_id id) +let encode_mind dir id = make_mind (MPfile dir) empty_dirpath (label_of_id id) let encode_con dir id = make_con (MPfile dir) empty_dirpath (label_of_id id) -let decode_kn kn = - let rec dirpath_of_module = function +let decode_mind kn = + let rec dir_of_mp = function | MPfile dir -> repr_dirpath dir - | MPbound mbid -> + | MPbound mbid -> let _,_,dp = repr_mbid mbid in let id = id_of_mbid mbid in id::(repr_dirpath dp) - | MPself msid -> - let _,_,dp = repr_msid msid in - let id = id_of_msid msid in - id::(repr_dirpath dp) - | MPdot(mp,l) -> (id_of_label l)::(dirpath_of_module mp) + | MPdot(mp,l) -> (id_of_label l)::(dir_of_mp mp) in - let mp,sec_dir,l = repr_kn kn in + let mp,sec_dir,l = repr_mind kn in if (repr_dirpath sec_dir) = [] then - (make_dirpath (dirpath_of_module mp)),id_of_label l + (make_dirpath (dir_of_mp mp)),id_of_label l else anomaly "Section part should be empty!" @@ -289,8 +303,8 @@ let pop_con con = Names.make_con mp (pop_dirpath dir) l let pop_kn kn = - let (mp,dir,l) = repr_kn kn in - Names.make_kn mp (pop_dirpath dir) l + let (mp,dir,l) = repr_mind kn in + Names.make_mind mp (pop_dirpath dir) l let pop_global_reference = function | ConstRef con -> ConstRef (pop_con con) diff --git a/library/libnames.mli b/library/libnames.mli index 43ca252c1..fd2ca37ae 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -28,11 +28,14 @@ val isConstRef : global_reference -> bool val isIndRef : global_reference -> bool val isConstructRef : global_reference -> bool +val eq_gr : global_reference -> global_reference -> bool + val destVarRef : global_reference -> variable val destConstRef : global_reference -> constant val destIndRef : global_reference -> inductive val destConstructRef : global_reference -> constructor + val subst_constructor : substitution -> constructor -> constructor * constr val subst_global : substitution -> global_reference -> global_reference * constr @@ -47,6 +50,12 @@ val global_of_constr : constr -> global_reference val constr_of_reference : global_reference -> constr val reference_of_constr : constr -> global_reference +module RefOrdered : sig + type t = global_reference + val compare : global_reference -> global_reference -> int +end + + module Refset : Set.S with type elt = global_reference module Refmap : Map.S with type key = global_reference @@ -108,8 +117,8 @@ val restrict_path : int -> full_path -> full_path (*s Temporary function to brutally form kernel names from section paths *) -val encode_kn : dir_path -> identifier -> kernel_name -val decode_kn : kernel_name -> dir_path * identifier +val encode_mind : dir_path -> identifier -> mutual_inductive +val decode_mind : mutual_inductive -> dir_path * identifier val encode_con : dir_path -> identifier -> constant val decode_con : constant -> dir_path * identifier @@ -170,7 +179,7 @@ val loc_of_reference : reference -> loc (*s Popping one level of section in global names *) val pop_con : constant -> constant -val pop_kn : kernel_name -> kernel_name +val pop_kn : mutual_inductive-> mutual_inductive val pop_global_reference : global_reference -> global_reference (* Deprecated synonyms *) diff --git a/library/libobject.ml b/library/libobject.ml index 4bd701e13..ecdcacf1d 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -34,7 +34,7 @@ type 'a object_declaration = { load_function : int -> object_name * 'a -> unit; open_function : int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; - subst_function : object_name * substitution * 'a -> 'a; + subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } @@ -63,7 +63,7 @@ let default_object s = { This helps introducing new functions in objects. *) -let ident_subst_function (_,_,a) = a +let ident_subst_function (_,a) = a type obj = Dyn.t (* persistent dynamic objects *) @@ -71,7 +71,7 @@ type dynamic_object_declaration = { dyn_cache_function : object_name * obj -> unit; dyn_load_function : int -> object_name * obj -> unit; dyn_open_function : int -> object_name * obj -> unit; - dyn_subst_function : object_name * substitution * obj -> obj; + dyn_subst_function : substitution * obj -> obj; dyn_classify_function : obj -> obj substitutivity; dyn_discharge_function : object_name * obj -> obj option; dyn_rebuild_function : obj -> obj } @@ -93,9 +93,9 @@ let declare_object odecl = and opener i (oname,lobj) = if Dyn.tag lobj = na then odecl.open_function i (oname,outfun lobj) else anomaly "somehow we got the wrong dynamic object in the openfun" - and substituter (oname,sub,lobj) = - if Dyn.tag lobj = na then - infun (odecl.subst_function (oname,sub,outfun lobj)) + and substituter (sub,lobj) = + if Dyn.tag lobj = na then + infun (odecl.subst_function (sub,outfun lobj)) else anomaly "somehow we got the wrong dynamic object in the substfun" and classifier lobj = if Dyn.tag lobj = na then @@ -158,7 +158,7 @@ let load_object i ((_,lobj) as node) = let open_object i ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_open_function i node) lobj -let subst_object ((_,_,lobj) as node) = +let subst_object ((_,lobj) as node) = apply_dyn_fun lobj (fun d -> d.dyn_subst_function node) lobj let classify_object lobj = diff --git a/library/libobject.mli b/library/libobject.mli index 834a70c64..9c0abafde 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -70,7 +70,7 @@ type 'a object_declaration = { load_function : int -> object_name * 'a -> unit; open_function : int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; - subst_function : object_name * substitution * 'a -> 'a; + subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } @@ -86,7 +86,7 @@ type 'a object_declaration = { val default_object : string -> 'a object_declaration (* the identity substitution function *) -val ident_subst_function : object_name * substitution * 'a -> 'a +val ident_subst_function : substitution * 'a -> 'a (*s Given an object declaration, the function [declare_object] will hand back two functions, the "injection" and "projection" @@ -102,7 +102,7 @@ val object_tag : obj -> string val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit val open_object : int -> object_name * obj -> unit -val subst_object : object_name * substitution * obj -> obj +val subst_object : substitution * obj -> obj val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj diff --git a/library/library.ml b/library/library.ml index d129a24db..fbe437fc4 100644 --- a/library/library.ml +++ b/library/library.ml @@ -302,7 +302,7 @@ let open_import i (_,(dir,export)) = let cache_import obj = open_import 1 obj -let subst_import (_,_,o) = o +let subst_import (_,o) = o let classify_import (_,export as obj) = if export then Substitute obj else Dispose diff --git a/library/nametab.ml b/library/nametab.ml index 31915c95a..c14b6cfc0 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -314,18 +314,26 @@ let the_tacticrevtab = ref (KNmap.empty : knrevtab) Parameter but also Remark and Fact) *) let push_xref visibility sp xref = - the_ccitab := SpTab.push visibility sp xref !the_ccitab; match visibility with | Until _ -> - if Globrevtab.mem xref !the_globrevtab then - () - else - the_globrevtab := Globrevtab.add xref sp !the_globrevtab - | _ -> () + the_ccitab := SpTab.push visibility sp xref !the_ccitab; + the_globrevtab := Globrevtab.add xref sp !the_globrevtab + | _ -> + begin + if SpTab.exists sp !the_ccitab then + match SpTab.find sp !the_ccitab with + | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) | + TrueGlobal( ConstructRef _) as xref -> + the_ccitab := SpTab.push visibility sp xref !the_ccitab; + | _ -> + the_ccitab := SpTab.push visibility sp xref !the_ccitab; + else + the_ccitab := SpTab.push visibility sp xref !the_ccitab; + end let push_cci visibility sp ref = push_xref visibility sp (TrueGlobal ref) - + (* This is for Syntactic Definitions *) let push_syndef visibility sp kn = push_xref visibility sp (SynDef kn) diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 12a3bb572..f96a94fb4 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -425,7 +425,7 @@ let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = | (_,"CONSTANT") -> Some (print_constant with_values sep (constant_of_kn kn)) | (_,"INDUCTIVE") -> - Some (gallina_print_inductive kn) + Some (gallina_print_inductive (mind_of_kn kn)) | (_,"MODULE") -> let (mp,_,l) = repr_kn kn in Some (print_module with_values (MPdot (mp,l))) @@ -540,7 +540,7 @@ let print_full_pure_context () = | ((_,kn),Lib.Leaf lobj)::rest -> let pp = match object_tag lobj with | "CONSTANT" -> - let con = constant_of_kn kn in + let con = Global.constant_of_delta (constant_of_kn kn) in let cb = Global.lookup_constant con in let val_0 = cb.const_body in let typ = ungeneralized_type_of_constant_type cb.const_type in @@ -559,9 +559,10 @@ let print_full_pure_context () = str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ print_body val_0) ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> - let (mib,mip) = Global.lookup_inductive (kn,0) in + let mind = Global.mind_of_delta (mind_of_kn kn) in + let (mib,mip) = Global.lookup_inductive (mind,0) in let mipv = mib.mind_packets in - let names = list_tabulate (fun x -> (kn,x)) (Array.length mipv) in + let names = list_tabulate (fun x -> (mind,x)) (Array.length mipv) in pr_mutual_inductive mib.mind_finite names ++ str "." ++ fnl () ++ fnl () | "MODULE" -> diff --git a/parsing/printmod.ml b/parsing/printmod.ml index a5470a892..80f05bf92 100644 --- a/parsing/printmod.ml +++ b/parsing/printmod.ml @@ -27,7 +27,7 @@ let rec print_local_modpath locals = function | MPbound mbid -> pr_id (List.assoc mbid locals) | MPdot(mp,l) -> print_local_modpath locals mp ++ str "." ++ pr_lab l - | MPself _ | MPfile _ -> raise Not_found + | MPfile _ -> raise Not_found let print_modpath locals mp = try (* must be with let because streams are lazy! *) @@ -58,9 +58,10 @@ let rec print_module name locals with_body mb = | true, Some mexpr -> spc () ++ str ":= " ++ print_modexpr locals mexpr in - let modtype = match mb.mod_type with - None -> str "" - | Some t -> spc () ++ str": " ++ + + let modtype = + match mb.mod_type with + | t -> spc () ++ str": " ++ print_modtype locals t in hv 2 (str "Module " ++ name ++ modtype ++ body) @@ -78,8 +79,8 @@ and print_modtype locals mty = pr_id (id_of_mbid mbid) ++ str " : " ++ print_modtype locals mtb1.typ_expr ++ str ")" ++ spc() ++ print_modtype locals' mtb2) - | SEBstruct (msid,sign) -> - hv 2 (str "Sig" ++ spc () ++ print_sig locals msid sign ++ brk (1,-2) ++ str "End") + | SEBstruct (sign) -> + hv 2 (str "Sig" ++ spc () ++ print_sig locals sign ++ brk (1,-2) ++ str "End") | SEBapply (mexpr,marg,_) -> let lapp = flatten_app mexpr [marg] in let fapp = List.hd lapp in @@ -90,31 +91,29 @@ and print_modtype locals mty = let s = (String.concat "." (List.map string_of_id idl)) in hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ str "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) - | SEBwith(seb,With_module_body(idl,mp,_,_))-> + | SEBwith(seb,With_module_body(idl,mp))-> let s =(String.concat "." (List.map string_of_id idl)) in hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) -and print_sig locals msid sign = +and print_sig locals sign = let print_spec (l,spec) = (match spec with | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition " | SFBconst {const_body=None} | SFBconst {const_opaque=true} -> str "Parameter " | SFBmind _ -> str "Inductive " | SFBmodule _ -> str "Module " - | SFBalias (mp,_,_) -> str "Module " | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l) in prlist_with_sep spc print_spec sign -and print_struct locals msid struc = +and print_struct locals struc = let print_body (l,body) = (match body with | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition " | SFBconst {const_body=Some _; const_opaque=true} -> str "Theorem " | SFBconst {const_body=None} -> str "Parameter " | SFBmind _ -> str "Inductive " | SFBmodule _ -> str "Module " - | SFBalias (mp,_,_) -> str "Module " | SFBmodtype _ -> str "Module Type ") ++ str (string_of_label l) in prlist_with_sep spc print_body struc @@ -128,8 +127,8 @@ and print_modexpr locals mexpr = match mexpr with hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ str ":" ++ print_modtype locals mty.typ_expr ++ str ")" ++ spc () ++ print_modexpr locals' mexpr) - | SEBstruct (msid, struc) -> - hv 2 (str "Struct" ++ spc () ++ print_struct locals msid struc ++ brk (1,-2) ++ str "End") + | SEBstruct ( struc) -> + hv 2 (str "Struct" ++ spc () ++ print_struct locals struc ++ brk (1,-2) ++ str "End") | SEBapply (mexpr,marg,_) -> let lapp = flatten_app mexpr [marg] in hov 3 (str"(" ++ prlist_with_sep spc (print_modexpr locals) lapp ++ str")") diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index e1edeec37..47381f6d8 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -203,7 +203,7 @@ let pop_visible, push_visible, get_visible, subst_mp = and push mp o = vis := { mp = mp; content = Hashtbl.create 97 } :: !vis; let s = List.hd !sub in - let s = match o with None -> s | Some msid -> add_msid msid mp s in + let s = match o with None -> s | Some msid -> add_mp msid mp empty_delta_resolver s in sub := s :: !sub and get () = !vis and subst mp = subst_mp (List.hd !sub) mp @@ -278,7 +278,6 @@ let rec mp_renaming_fun mp = match mp with let lmp = mp_renaming mp in if lmp = [""] then (modfstlev_rename l)::lmp else (modular_rename Mod (id_of_label l))::lmp - | MPself msid -> [modular_rename Mod (id_of_msid msid)] | MPbound mbid -> [modular_rename Mod (id_of_mbid mbid)] | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *) | MPfile _ -> diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index c401bd059..a68e72d26 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -45,7 +45,7 @@ val pp_global : kind -> global_reference -> string val pp_module : module_path -> string val top_visible_mp : unit -> module_path -val push_visible : module_path -> mod_self_id option -> unit +val push_visible : module_path -> module_path option -> unit val pop_visible : unit -> unit val check_duplicate : module_path -> label -> string diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index ba4786d37..37721c9b9 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -32,7 +32,7 @@ let toplevel_env () = let mp,_,l = repr_kn kn in let seb = match Libobject.object_tag o with | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn)) - | "INDUCTIVE" -> SFBmind (Global.lookup_mind kn) + | "INDUCTIVE" -> SFBmind (Global.lookup_mind (mind_of_kn kn)) | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l))) | "MODULE TYPE" -> SFBmodtype (Global.lookup_modtype (MPdot (mp,l))) @@ -41,8 +41,8 @@ let toplevel_env () = | _ -> failwith "caught" in match current_toplevel () with - | MPself msid -> SEBstruct (msid, List.rev (map_succeed get_reference seg)) - | _ -> assert false + | _ -> SEBstruct (List.rev (map_succeed get_reference seg)) + let environment_until dir_opt = let rec parse = function @@ -69,7 +69,7 @@ module type VISIT = sig (* Add kernel_name / constant / reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) - val add_kn : kernel_name -> unit + val add_kn : mutual_inductive -> unit val add_con : constant -> unit val add_ref : global_reference -> unit val add_decl_deps : ml_decl -> unit @@ -77,7 +77,7 @@ module type VISIT = sig (* Test functions: is a particular object a needed dependency for the current extraction ? *) - val needed_kn : kernel_name -> bool + val needed_kn : mutual_inductive -> bool val needed_con : constant -> bool val needed_mp : module_path -> bool end @@ -87,17 +87,17 @@ module Visit : VISIT = struct (for inductives and modules names) and a Cset for constants (and still the remaining MPset) *) type must_visit = - { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t } + { mutable kn : Mindset.t; mutable con : Cset.t; mutable mp : MPset.t } (* the imperative internal visit lists *) - let v = { kn = KNset.empty ; con = Cset.empty ; mp = MPset.empty } + let v = { kn = Mindset.empty ; con = Cset.empty ; mp = MPset.empty } (* the accessor functions *) - let reset () = v.kn <- KNset.empty; v.con <- Cset.empty; v.mp <- MPset.empty - let needed_kn kn = KNset.mem kn v.kn + let reset () = v.kn <- Mindset.empty; v.con <- Cset.empty; v.mp <- MPset.empty + let needed_kn kn = Mindset.mem kn v.kn let needed_con c = Cset.mem c v.con let needed_mp mp = MPset.mem mp v.mp let add_mp mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp - let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn) + let add_kn kn = v.kn <- Mindset.add kn v.kn; add_mp (mind_modpath kn) let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c) let add_ref = function | ConstRef c -> add_con c @@ -140,29 +140,29 @@ let factor_fix env l cb msb = labels, recd, msb'' end -let build_mb expr typ_opt = - { mod_expr = Some expr; +let build_mb mp expr typ_opt = + { mod_mp = mp; + mod_expr = Some expr; mod_type = typ_opt; + mod_type_alg = None; mod_constraints = Univ.Constraint.empty; - mod_alias = Mod_subst.empty_subst; + mod_delta = Mod_subst.empty_delta_resolver; mod_retroknowledge = [] } let my_type_of_mb env mb = - match mb.mod_type with - | Some mtb -> mtb - | None -> Modops.eval_struct env (Option.get mb.mod_expr) + mb.mod_type (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. To check with Elie. *) -let env_for_mtb_with env mtb idl = - let msid,sig_b = match Modops.eval_struct env mtb with - | SEBstruct(msid,sig_b) -> msid,sig_b +let env_for_mtb_with env mp mtb idl = + let sig_b = match mtb with + | SEBstruct(sig_b) -> sig_b | _ -> assert false in let l = label_of_id (List.hd idl) in let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in - Modops.add_signature (MPself msid) before env + Modops.add_signature mp before empty_delta_resolver env (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) @@ -177,20 +177,18 @@ let rec extract_sfb_spec env mp = function else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmind _) :: msig -> let kn = make_kn mp empty_dirpath l in - let s = Sind (kn, extract_inductive env kn) in + let mind = mind_of_kn kn in + let s = Sind (kn, extract_inductive env mind) in let specs = extract_sfb_spec env mp msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> let specs = extract_sfb_spec env mp msig in - let spec = extract_seb_spec env (my_type_of_mb env mb) in + let spec = extract_seb_spec env mb.mod_mp (my_type_of_mb env mb) in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> let specs = extract_sfb_spec env mp msig in - (l,Smodtype (extract_seb_spec env mtb.typ_expr)) :: specs - | (l,SFBalias (mp1,typ_opt,_)) :: msig -> - let mb = build_mb (SEBident mp1) typ_opt in - extract_sfb_spec env mp ((l,SFBmodule mb) :: msig) + (l,Smodtype (extract_seb_spec env mtb.typ_mp mtb.typ_expr)) :: specs (* From [struct_expr_body] to specifications *) @@ -201,34 +199,35 @@ let rec extract_sfb_spec env mp = function For instance, [my_type_of_mb] ensures this invariant. *) -and extract_seb_spec env = function +and extract_seb_spec env mp1 = function | SEBident mp -> Visit.add_mp mp; MTident mp | SEBwith(mtb',With_definition_body(idl,cb))-> - let env' = env_for_mtb_with env mtb' idl in - let mtb''= extract_seb_spec env mtb' in + let env' = env_for_mtb_with env mp1 mtb' idl in + let mtb''= extract_seb_spec env mp1 mtb' in (match extract_with_type env' cb with (* cb peut contenir des kn *) | None -> mtb'' | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ))) - | SEBwith(mtb',With_module_body(idl,mp,_,_))-> + | SEBwith(mtb',With_module_body(idl,mp))-> Visit.add_mp mp; - MTwith(extract_seb_spec env mtb', + MTwith(extract_seb_spec env mp1 mtb', ML_With_module(idl,mp)) (* TODO: On pourrait peut-etre oter certaines eta-expansion, du genre: | SEBfunctor(mbid,_,SEBapply(m,SEBident (MPbound mbid2),_)) when mbid = mbid2 -> extract_seb_spec env m (* faudrait alors ajouter un test de non-apparition de mbid dans mb *) *) - | SEBfunctor (mbid, mtb, mtb') -> + | SEBfunctor (mbid, mtb, mtb') -> let mp = MPbound mbid in - let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MTfunsig (mbid, extract_seb_spec env mtb.typ_expr, - extract_seb_spec env' mtb') - | SEBstruct (msid, msig) -> - let mp = MPself msid in - let env' = Modops.add_signature mp msig env in - MTsig (msid, extract_sfb_spec env' mp msig) - | SEBapply _ as mtb -> - extract_seb_spec env (Modops.eval_struct env mtb) + let env' = Modops.add_module (Modops.module_body_of_type mp mtb) + env in + MTfunsig (mbid, extract_seb_spec env mp mtb.typ_expr, + extract_seb_spec env' mp1 mtb') + | SEBstruct (msig) -> + let env' = Modops.add_signature mp1 msig empty_delta_resolver env in + MTsig (mp1, extract_sfb_spec env' mp1 msig) + | SEBapply _ -> + assert false + (* From a [structure_body] (i.e. a list of [structure_field_body]) @@ -263,9 +262,10 @@ let rec extract_sfb env mp all = function | (l,SFBmind mib) :: msb -> let ms = extract_sfb env mp all msb in let kn = make_kn mp empty_dirpath l in - let b = Visit.needed_kn kn in + let mind = mind_of_kn kn in + let b = Visit.needed_kn mind in if all || b then - let d = Dind (kn, extract_inductive env kn) in + let d = Dind (kn, extract_inductive env mind) in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms @@ -279,40 +279,34 @@ let rec extract_sfb env mp all = function let ms = extract_sfb env mp all msb in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then - (l,SEmodtype (extract_seb_spec env mtb.typ_expr)) :: ms + (l,SEmodtype (extract_seb_spec env mp mtb.typ_expr)) :: ms else ms - | (l,SFBalias (mp1,typ_opt,_)) :: msb -> - let mb = build_mb (SEBident mp1) typ_opt in - extract_sfb env mp all ((l,SFBmodule mb) :: msb) (* From [struct_expr_body] to implementations *) -and extract_seb env mpo all = function +and extract_seb env mp all = function | SEBident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp mp; MEident mp | SEBapply (meb, meb',_) -> - MEapply (extract_seb env None true meb, - extract_seb env None true meb') + MEapply (extract_seb env mp true meb, + extract_seb env mp true meb') | SEBfunctor (mbid, mtb, meb) -> - let mp = MPbound mbid in - let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MEfunctor (mbid, extract_seb_spec env mtb.typ_expr, - extract_seb env' None true meb) - | SEBstruct (msid, msb) -> - let mp,msb = match mpo with - | None -> MPself msid, msb - | Some mp -> mp, Modops.subst_structure (map_msid msid mp) msb - in - let env' = Modops.add_signature mp msb env in - MEstruct (msid, extract_sfb env' mp all msb) + let mp1 = MPbound mbid in + let env' = Modops.add_module (Modops.module_body_of_type mp1 mtb) + env in + MEfunctor (mbid, extract_seb_spec env mp1 mtb.typ_expr, + extract_seb env' mp true meb) + | SEBstruct (msb) -> + let env' = Modops.add_signature mp msb empty_delta_resolver env in + MEstruct (mp,extract_sfb env' mp all msb) | SEBwith (_,_) -> anomaly "Not available yet" and extract_module env mp all mb = (* [mb.mod_expr <> None ], since we look at modules from outside. *) (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *) - { ml_mod_expr = extract_seb env (Some mp) all (Option.get mb.mod_expr); - ml_mod_type = extract_seb_spec env (my_type_of_mb env mb) } + { ml_mod_expr = extract_seb env mp all (Option.get mb.mod_expr); + ml_mod_type = extract_seb_spec env mp (my_type_of_mb env mb) } let unpack = function MEstruct (_,sel) -> sel | _ -> assert false @@ -324,7 +318,7 @@ let mono_environment refs mpl = let env = Global.env () in let l = List.rev (environment_until None) in List.rev_map - (fun (mp,m) -> mp, unpack (extract_seb env (Some mp) false m)) l + (fun (mp,m) -> mp, unpack (extract_seb env mp false m)) l (**************************************) (*S Part II : Input/Output primitives *) @@ -514,7 +508,7 @@ let extraction_library is_rec m = let l = List.rev (environment_until (Some dir_m)) in let select l (mp,meb) = if Visit.needed_mp mp - then (mp, unpack (extract_seb env (Some mp) true meb)) :: l + then (mp, unpack (extract_seb env mp true meb)) :: l else l in let struc = List.fold_left select [] l in diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 3468e8a36..d119dbe8e 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -310,7 +310,15 @@ and extract_ind env kn = (* kn is supposed to be in long form *) with Not_found -> (* First, if this inductive is aliased via a Module, *) (* we process the original inductive. *) - Option.iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv; + let equiv = + if (canonical_mind kn) = (user_mind kn) then + NoEquiv + else + begin + ignore (extract_ind env (mind_of_kn (canonical_mind kn))); + Equiv (canonical_mind kn) + end + in (* Everything concerning parameters. *) (* We do that first, since they are common to all the [mib]. *) let mip0 = mib.mind_packets.(0) in @@ -333,13 +341,12 @@ and extract_ind env kn = (* kn is supposed to be in long form *) ip_types = t }) mib.mind_packets in + add_ind kn mib {ind_info = Standard; ind_nparams = npar; ind_packets = packets; - ind_equiv = match mib.mind_equiv with - | None -> NoEquiv - | Some kn -> Equiv kn + ind_equiv = equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do @@ -388,7 +395,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in assert (List.length field_names = List.length typ); let projs = ref Cset.empty in - let mp,d,_ = repr_kn kn in + let mp,d,_ = repr_mind kn in let rec select_fields l typs = match l,typs with | [],[] -> [] | (Name id)::l, typ::typs -> @@ -424,9 +431,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets; - ind_equiv = match mib.mind_equiv with - | None -> NoEquiv - | Some kn -> Equiv kn } + ind_equiv = equiv } in add_ind kn mib i; i diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 2c534ea7b..6bcd24763 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -26,7 +26,7 @@ val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) op val extract_fixpoint : env -> constant array -> (constr, types) prec_declaration -> ml_decl -val extract_inductive : env -> kernel_name -> ml_ind +val extract_inductive : env -> mutual_inductive -> ml_ind (*s Is a [ml_decl] or a [ml_spec] logical ? *) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 9d45c08b7..6973bb454 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -84,7 +84,7 @@ let rec pp_type par vl t = | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r | Tglob (r,l) -> - if r = IndRef (kn_sig,0) then + if r = IndRef (mind_of_kn kn_sig,0) then pp_type true vl (List.hd l) else pp_par par @@ -269,8 +269,8 @@ let pp_string_parameters ids = prlist (fun id -> str id ++ str " ") let pp_decl = function | Dind (kn,i) when i.ind_info = Singleton -> - pp_singleton kn i.ind_packets.(0) ++ fnl () - | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) + pp_singleton (mind_of_kn kn) i.ind_packets.(0) ++ fnl () + | Dind (kn,i) -> hov 0 (pp_ind true (mind_of_kn kn) 0 i) | Dtype (r, l, t) -> if is_inline_custom r then mt () else diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index 55231d766..91c60d205 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -128,7 +128,7 @@ type ml_specif = and ml_module_type = | MTident of module_path | MTfunsig of mod_bound_id * ml_module_type * ml_module_type - | MTsig of mod_self_id * ml_module_sig + | MTsig of module_path * ml_module_sig | MTwith of ml_module_type * ml_with_declaration and ml_with_declaration = @@ -145,7 +145,7 @@ type ml_structure_elem = and ml_module_expr = | MEident of module_path | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr - | MEstruct of mod_self_id * ml_module_structure + | MEstruct of module_path * ml_module_structure | MEapply of ml_module_expr * ml_module_expr and ml_module_structure = (label * ml_structure_elem) list diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 213df31e6..2e9fb8bf2 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -649,9 +649,9 @@ let generalizable_list = let datatypes = MPfile (dirpath_of_string "Coq.Init.Datatypes") and specif = MPfile (dirpath_of_string "Coq.Init.Specif") in - [ make_kn datatypes empty_dirpath (mk_label "bool"); - make_kn specif empty_dirpath (mk_label "sumbool"); - make_kn specif empty_dirpath (mk_label "sumor") ] + [ make_mind datatypes empty_dirpath (mk_label "bool"); + make_mind specif empty_dirpath (mk_label "sumbool"); + make_mind specif empty_dirpath (mk_label "sumor") ] let check_generalizable_case unsafe br = if not unsafe then diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 4b6b47ab9..9c5feac82 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -50,7 +50,7 @@ end (*s Utility functions over ML types without meta *) -val type_mem_kn : kernel_name -> ml_type -> bool +val type_mem_kn : mutual_inductive -> ml_type -> bool val type_maxvar : ml_type -> int diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 1b1a39770..9195b747e 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -21,11 +21,7 @@ open Mod_subst (*S Functions upon ML modules. *) let rec msid_of_mt = function - | MTident mp -> begin - match Modops.eval_struct (Global.env()) (SEBident mp) with - | SEBstruct(msid,_) -> MPself msid - | _ -> anomaly "Extraction:the With can't be applied to a funsig" - end + | MTident mp -> mp | MTwith(mt,_)-> msid_of_mt mt | _ -> anomaly "Extraction:the With operator isn't applied to a name" @@ -101,25 +97,26 @@ let ind_iter_references do_term do_cons do_type kn ind = do_type (IndRef ip); if lang () = Ocaml then (match ind.ind_equiv with - | Equiv kne -> do_type (IndRef (kne, snd ip)); + | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip)); | _ -> ()); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types in if lang () = Ocaml then record_iter_references do_term ind.ind_info; - Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets + Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets let decl_iter_references do_term do_cons do_type = let type_iter = type_iter_references do_type and ast_iter = ast_iter_references do_term do_cons do_type in function - | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind + | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type + (mind_of_kn kn) ind | Dtype (r,_,t) -> do_type r; type_iter t | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t | Dfix(rv,c,t) -> Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t let spec_iter_references do_term do_cons do_type = function - | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind + | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type (mind_of_kn kn) ind | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot | Sval (r,t) -> do_term r; type_iter_references do_type t @@ -190,7 +187,7 @@ let signature_of_structure s = (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) let get_decl_in_structure r struc = - try + try let base_mp,ll = labels_of_ref r in if not (at_toplevel base_mp) then error_not_visible r; let sel = List.assoc base_mp struc in @@ -311,7 +308,7 @@ let reset_needed, add_needed, found_needed, is_needed = (fun r -> Refset.mem (base_r r) !needed)) let declared_refs = function - | Dind (kn,_) -> [|IndRef (kn,0)|] + | Dind (kn,_) -> [|IndRef (mind_of_kn kn,0)|] | Dtype (r,_,_) -> [|r|] | Dterm (r,_,_) -> [|r|] | Dfix (rv,_,_) -> rv @@ -322,7 +319,7 @@ let declared_refs = function let compute_deps_decl = function | Dind (kn,ind) -> (* Todo Later : avoid dependencies when Extract Inductive *) - ind_iter_references add_needed add_needed add_needed kn ind + ind_iter_references add_needed add_needed add_needed (mind_of_kn kn) ind | Dtype (r,ids,t) -> if not (is_custom r) then type_iter_references add_needed t | Dterm (r,u,t) -> diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 93fc2c2dc..107b5368f 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -122,7 +122,7 @@ let find_projections = function Record l -> l | _ -> raise NoRecord let kn_sig = let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in - make_kn specif empty_dirpath (mk_label "sig") + make_mind specif empty_dirpath (mk_label "sig") let rec pp_type par vl t = let rec pp_rec par = function @@ -380,7 +380,7 @@ let pp_Dfix (rv,c,t) = let pp_equiv param_list name = function | NoEquiv, _ -> mt () | Equiv kn, i -> - str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (kn,i)) + str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (mind_of_kn kn,i)) | RenEquiv ren, _ -> str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name @@ -408,7 +408,7 @@ let pp_logical_ind packet = fnl () let pp_singleton kn packet = - let name = pp_global Type (IndRef (kn,0)) in + let name = pp_global Type (IndRef (mind_of_kn kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ @@ -416,7 +416,7 @@ let pp_singleton kn packet = pr_id packet.ip_consnames.(0))) let pp_record kn projs ip_equiv packet = - let name = pp_global Type (IndRef (kn,0)) in + let name = pp_global Type (IndRef (mind_of_kn kn,0)) in let projnames = List.map (pp_global Term) projs in let l = List.combine projnames packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in @@ -438,20 +438,20 @@ let pp_ind co kn ind = let init= ref (str "type ") in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else - pp_global Type (IndRef (kn,i))) + pp_global Type (IndRef (mind_of_kn kn,i))) ind.ind_packets in let cnames = Array.mapi (fun i p -> if p.ip_logical then [||] else - Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1))) + Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((mind_of_kn kn,i),j+1))) p.ip_types) ind.ind_packets in let rec pp i = if i >= Array.length ind.ind_packets then mt () else - let ip = (kn,i) in + let ip = (mind_of_kn kn,i) in let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in if is_custom (IndRef ip) then pp (i+1) @@ -601,12 +601,12 @@ and pp_module_type ol = function let name = pp_modname (MPbound mbid) in let def = pp_module_type None mt' in str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def - | MTsig (msid, sign) -> + | MTsig (mp1, sign) -> let tvm = top_visible_mp () in - let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in + let mp = match ol with None -> mp1 | Some l -> MPdot (tvm,l) in (* References in [sign] are in short form (relative to [msid]). In push_visible, [msid-->mp] is added to the current subst. *) - push_visible mp (Some msid); + push_visible mp (Some mp1); let l = map_succeed pp_specif sign in pop_visible (); str "sig " ++ fnl () ++ @@ -684,9 +684,9 @@ and pp_module_expr ol = function str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MEapply (me, me') -> pp_module_expr None me ++ str "(" ++ pp_module_expr None me' ++ str ")" - | MEstruct (msid, sel) -> + | MEstruct (mp, sel) -> let tvm = top_visible_mp () in - let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in + let mp = match ol with None -> mp | Some l -> MPdot (tvm,l) in (* No need to update the subst with [Some msid] below : names are already in long form (see [subst_structure] in [Extract_env]). *) push_visible mp None; diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 9451188aa..043bf0fe7 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -31,13 +31,13 @@ let occur_kn_in_ref kn = function let modpath_of_r = function | ConstRef kn -> con_modpath kn | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> modpath kn + | ConstructRef ((kn,_),_) -> mind_modpath kn | VarRef _ -> assert false let label_of_r = function | ConstRef kn -> con_label kn | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> label kn + | ConstructRef ((kn,_),_) -> mind_label kn | VarRef _ -> assert false let rec base_mp = function @@ -93,15 +93,34 @@ let rec parse_labels ll = function let labels_of_mp mp = parse_labels [] mp +let rec parse_labels2 ll mp1 = function + | mp when mp1=mp -> mp,ll + | MPdot (mp,l) -> parse_labels (l::ll) mp + | mp -> mp,ll + let labels_of_ref r = - let mp,_,l = + let mp_top = fst(Lib.current_prefix()) in + let mp,_,l = + match r with + ConstRef con -> repr_con con + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> repr_mind kn + | VarRef _ -> assert false + in + parse_labels2 [l] mp_top mp + + + + +let labels_of_ref2 r = + let mp1,_,l = match r with ConstRef con -> repr_con con | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> repr_kn kn + | ConstructRef ((kn,_),_) -> repr_mind kn | VarRef _ -> assert false - in - parse_labels [l] mp + in mp1,l + let rec add_labels_mp mp = function | [] -> mp @@ -127,10 +146,10 @@ let lookup_type kn = Cmap.find kn !types (*s Inductives table. *) -let inductives = ref (KNmap.empty : (mutual_inductive_body * ml_ind) KNmap.t) -let init_inductives () = inductives := KNmap.empty -let add_ind kn mib ml_ind = inductives := KNmap.add kn (mib,ml_ind) !inductives -let lookup_ind kn = KNmap.find kn !inductives +let inductives = ref (Mindmap.empty : (mutual_inductive_body * ml_ind) Mindmap.t) +let init_inductives () = inductives := Mindmap.empty +let add_ind kn mib ml_ind = inductives := Mindmap.add kn (mib,ml_ind) !inductives +let lookup_ind kn = Mindmap.find kn !inductives (*s Recursors table. *) @@ -138,7 +157,7 @@ let recursors = ref Cset.empty let init_recursors () = recursors := Cset.empty let add_recursors env kn = - let make_kn id = make_con (modpath kn) empty_dirpath (label_of_id id) in + let make_kn id = make_con (mind_modpath kn) empty_dirpath (label_of_id id) in let mib = Environ.lookup_mind kn env in Array.iter (fun mip -> @@ -305,7 +324,13 @@ let error_record r = let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then - err (str ("Please load library "^(string_of_dirpath dp^" first."))) + let mp1 = (fst(Lib.current_prefix())) in + let rec find_prefix = function + |MPfile dp1 when dp=dp1 -> () + |MPdot(mp,_) -> find_prefix mp + |MPbound(_) -> () + | _ -> err (str ("Please load library "^(string_of_dirpath dp^" first."))) + in find_prefix mp1 | _ -> () let info_file f = @@ -450,7 +475,7 @@ let (inline_extraction,_) = load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); classify_function = (fun o -> Substitute o); subst_function = - (fun (_,s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) + (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) } let _ = declare_summary "Extraction Inline" @@ -528,7 +553,7 @@ let (blacklist_extraction,_) = cache_function = (fun (_,l) -> add_blacklist_entries l); load_function = (fun _ (_,l) -> add_blacklist_entries l); classify_function = (fun o -> Libobject.Keep o); - subst_function = (fun (_,_,x) -> x) + subst_function = (fun (_,x) -> x) } let _ = declare_summary "Extraction Blacklist" @@ -585,7 +610,7 @@ let (in_customs,_) = load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); classify_function = (fun o -> Substitute o); subst_function = - (fun (_,s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) + (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) } let _ = declare_summary "ML extractions" diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 42ed6eef0..512ecca74 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -38,7 +38,7 @@ val info_file : string -> unit (*s utilities about [module_path] and [kernel_names] and [global_reference] *) -val occur_kn_in_ref : kernel_name -> global_reference -> bool +val occur_kn_in_ref : mutual_inductive -> global_reference -> bool val modpath_of_r : global_reference -> module_path val label_of_r : global_reference -> label val current_toplevel : unit -> module_path @@ -56,6 +56,7 @@ val common_prefix_from_list : module_path -> module_path list -> module_path val add_labels_mp : module_path -> label list -> module_path val get_nth_label_mp : int -> module_path -> label val labels_of_ref : global_reference -> module_path * label list +val labels_of_ref2 : global_reference -> module_path * label (*s Some table-related operations *) @@ -65,10 +66,10 @@ val lookup_term : constant -> ml_decl val add_type : constant -> ml_schema -> unit val lookup_type : constant -> ml_schema -val add_ind : kernel_name -> mutual_inductive_body -> ml_ind -> unit -val lookup_ind : kernel_name -> mutual_inductive_body * ml_ind +val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit +val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind -val add_recursors : Environ.env -> kernel_name -> unit +val add_recursors : Environ.env -> mutual_inductive -> unit val is_recursor : global_reference -> bool val add_projection : int -> constant -> unit diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4 index 7ac5f4e89..91c0ca21e 100644 --- a/plugins/field/field.ml4 +++ b/plugins/field/field.ml4 @@ -60,7 +60,7 @@ let _ = let load_addfield _ = () let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab -let subst_addfield (_,subst,(typ,th as obj)) = +let subst_addfield (subst,(typ,th as obj)) = let typ' = subst_mps subst typ in let th' = subst_mps subst th in if typ' == typ && th' == th then obj else diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 600a9123b..19a884323 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -317,9 +317,9 @@ let cache_Function (_,finfos) = let load_Function _ = cache_Function let open_Function _ = cache_Function -let subst_Function (_,subst,finfos) = +let subst_Function (subst,finfos) = let do_subst_con c = fst (Mod_subst.subst_con subst c) - and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i) + and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i) in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in diff --git a/plugins/interface/centaur.ml4 b/plugins/interface/centaur.ml4 index e7084fbb0..07f32b6d4 100644 --- a/plugins/interface/centaur.ml4 +++ b/plugins/interface/centaur.ml4 @@ -416,7 +416,7 @@ let inspect n = | (sp,kn), "MUTUALINDUCTIVE" -> add_search2 (Nametab.locate (qualid_of_path sp)) (Pretyping.Default.understand Evd.empty (Global.env()) - (RRef(dummy_loc, IndRef(kn,0)))) + (RRef(dummy_loc, IndRef((mind_of_kn kn),0)))) | _ -> failwith ("unexpected value 1 for "^ (string_of_id (basename (fst oname))))) | _ -> failwith "unexpected value") diff --git a/plugins/interface/name_to_ast.ml b/plugins/interface/name_to_ast.ml index ef61a8202..142116ade 100644 --- a/plugins/interface/name_to_ast.ml +++ b/plugins/interface/name_to_ast.ml @@ -176,10 +176,11 @@ let inductive_to_ast_list sp = let leaf_entry_to_ast_list ((sp,kn),lobj) = let tag = object_tag lobj in + let con = constant_of_kn kn in match tag with | "VARIABLE" -> variable_to_ast_list (basename sp) - | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn) - | "INDUCTIVE" -> inductive_to_ast_list kn + | "CONSTANT" -> constant_to_ast_list con + | "INDUCTIVE" -> inductive_to_ast_list (mind_of_kn kn) | s -> errorlabstrm "print" (str ("printing of unrecognized object " ^ diff --git a/plugins/interface/name_to_ast.mli b/plugins/interface/name_to_ast.mli index a532604f5..db2555550 100644 --- a/plugins/interface/name_to_ast.mli +++ b/plugins/interface/name_to_ast.mli @@ -2,4 +2,4 @@ val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;; val inductive_to_ast_list : Names.mutual_inductive -> Vernacexpr.vernac_expr list;; val constant_to_ast_list : Names.constant -> Vernacexpr.vernac_expr list;; val variable_to_ast_list : Names.variable -> Vernacexpr.vernac_expr list;; -val leaf_entry_to_ast_list : (Libnames.full_path * Names.mutual_inductive) * Libobject.obj -> Vernacexpr.vernac_expr list;; +val leaf_entry_to_ast_list : (Libnames.full_path * Names.kernel_name) * Libobject.obj -> Vernacexpr.vernac_expr list;; diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index 6ee12ebcb..c0b5542ee 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -258,7 +258,7 @@ let subst_theory subst th = } -let subst_th (_,subst,(c,th as obj)) = +let subst_th (subst,(c,th as obj)) = let c' = subst_mps subst c in let th' = subst_theory subst th in if c' == c && th' == th then obj else diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index a930fee17..e85c12c59 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -400,7 +400,7 @@ let add_entry (sp,_kn) e = from_name := Spmap.add sp e !from_name -let subst_th (_,subst,th) = +let subst_th (subst,th) = let c' = subst_mps subst th.ring_carrier in let eq' = subst_mps subst th.ring_req in let set' = subst_mps subst th.ring_setoid in @@ -980,7 +980,7 @@ let add_field_entry (sp,_kn) e = field_from_relation := Cmap.add e.field_req e !field_from_relation; field_from_name := Spmap.add sp e !field_from_name -let subst_th (_,subst,th) = +let subst_th (subst,th) = let c' = subst_mps subst th.field_carrier in let eq' = subst_mps subst th.field_req in let thm1' = subst_mps subst th.field_ok in diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index d54bbee4e..4eb05df74 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -484,7 +484,7 @@ let check_and_adjust_constructor env ind cstrs = function | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in - if Closure.mind_equiv env ind' ind then + if Names.eq_ind ind' ind then (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index 76a8a0322..f617c1008 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -155,7 +155,7 @@ let cache (_, (infos, tac)) = let load (_, (_, tac)) = set_default_tactic tac -let subst (_, s, (infos, tac)) = +let subst (s, (infos, tac)) = (infos, Tacinterp.subst_tactic s tac) let (input,output) = diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index f60abaf85..19473dfa6 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -21,7 +21,7 @@ open Bigint exception Non_closed_ascii let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) -let make_kn dir id = Libnames.encode_kn (make_dir dir) (id_of_string id) +let make_kn dir id = Libnames.encode_mind (make_dir dir) (id_of_string id) let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) let ascii_module = ["Coq";"Strings";"Ascii"] diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index e58618219..21b7115b6 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -24,7 +24,7 @@ let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id) (* copied on g_zsyntax.ml, where it is said to be a temporary hack*) (* takes a path an identifier in the form of a string list and a string, returns a kernel_name *) -let make_kn dir id = Libnames.encode_kn (make_dir dir) (Names.id_of_string id) +let make_kn dir id = Libnames.encode_mind (make_dir dir) (Names.id_of_string id) (* int31 stuff *) @@ -50,9 +50,10 @@ let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2) let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ] let bigN_path = make_path (bigN_module@["BigN"]) "t" (* big ugly hack *) -let bigN_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), - Names.mk_label "BigN")), - [], Names.id_of_string id) : Names.kernel_name) +let bigN_id id = let kn = + ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), + Names.mk_label "BigN")), + [], Names.id_of_string id) in (Obj.magic (kn,kn) : Names.mutual_inductive) let bigN_scope = "bigN_scope" (* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *) @@ -81,9 +82,9 @@ let bigN_constructor = let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ] let bigZ_path = make_path (bigZ_module@["BigZ"]) "t" (* big ugly hack bis *) -let bigZ_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigZ_module)), +let bigZ_id id = let kn = ((Names.MPdot ((Names.MPfile (make_dir bigZ_module)), Names.mk_label "BigZ")), - [], Names.id_of_string id) : Names.kernel_name) + [], Names.id_of_string id) in (Obj.magic (kn,kn): Names.mutual_inductive) let bigZ_scope = "bigZ_scope" let bigZ_pos = ConstructRef ((bigZ_id "t_",0),1) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index a10c76013..f6afd080f 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -31,7 +31,7 @@ let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) let positive_path = make_path positive_module "positive" (* TODO: temporary hack *) -let make_kn dir id = Libnames.encode_kn dir id +let make_kn dir id = Libnames.encode_mind dir id let positive_kn = make_kn (make_dir positive_module) (id_of_string "positive") diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index 5bb7635b9..7706a3eb5 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -80,7 +80,7 @@ let get_uri_of_var v pvars = type tag = Constant of Names.constant - | Inductive of Names.kernel_name + | Inductive of Names.mutual_inductive | Variable of Names.kernel_name ;; @@ -165,7 +165,7 @@ let token_list_of_kernel_name tag = N.id_of_label (N.con_label con), Lib.remove_section_part (LN.ConstRef con) | Inductive kn -> - N.id_of_label (N.label kn), + N.id_of_label (N.mind_label kn), Lib.remove_section_part (LN.IndRef (kn,0)) in token_list_of_path dir id (etag_of_tag tag) diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index a46500b89..294f5154d 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -629,7 +629,7 @@ let _ = let _ = Declare.set_xml_declare_inductive (function (isrecord,(sp,kn)) -> - print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) + print false (Libnames.IndRef (Names.mind_of_kn kn,0)) (kind_of_inductive isrecord (Names.mind_of_kn kn)) xml_library_root) ;; diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 899fb64e1..9406a57d7 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -488,7 +488,7 @@ let check_and_adjust_constructor env ind cstrs = function | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in - if Closure.mind_equiv env ind' ind then + if eq_ind ind' ind then (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 35ffda0a1..7ec77f7dc 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -156,7 +156,7 @@ let subst_cl_typ subst ct = match ct with if kn' == kn then ct else fst (find_class_type (Global.env()) Evd.empty t) | CL_IND (kn,i) -> - let kn' = subst_kn subst kn in + let kn' = subst_ind subst kn in if kn' == kn then ct else CL_IND (kn',i) @@ -355,7 +355,7 @@ let load_coercion i (_,(coe,stre,isid,cls,clt,ps)) = let cache_coercion o = load_coercion 1 o -let subst_coercion (_,subst,(coe,stre,isid,cls,clt,ps as obj)) = +let subst_coercion (subst,(coe,stre,isid,cls,clt,ps as obj)) = let coe' = subst_coe_typ subst coe in let cls' = subst_cl_typ subst cls in let clt' = subst_cl_typ subst clt in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index f9c872f9e..16520916c 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -70,7 +70,7 @@ module PrintingCasesMake = type t = inductive * int array let encode = Test.encode let subst subst ((kn,i), ints as obj) = - let kn' = subst_kn subst kn in + let kn' = subst_ind subst kn in if kn' == kn then obj else (kn',i), ints let printer (ind,_) = pr_global_env Idset.empty (IndRef ind) @@ -566,7 +566,7 @@ let rec subst_cases_pattern subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_kn subst kn + let kn' = subst_ind subst kn and cpl' = list_smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -610,7 +610,7 @@ let rec subst_rawconstr subst raw = let (n,topt) = x in let topt' = Option.smartmap (fun (loc,(sp,i),x,y as t) -> - let sp' = subst_kn subst sp in + let sp' = subst_ind subst sp in if sp == sp' then t else (loc,(sp',i),x,y)) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = list_smartmap diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index b6e697e4d..10f4db77a 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -428,12 +428,12 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = evar_conv_x (push_rel (n,None,c) env) i pbty c'1 c'2)] | Ind sp1, Ind sp2 -> - if sp1=sp2 then + if eq_ind sp1 sp2 then ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2 else (evd, false) | Construct sp1, Construct sp2 -> - if sp1=sp2 then + if eq_constructor sp1 sp2 then ise_list2 evd (fun i -> evar_conv_x env i CONV) l1 l2 else (evd, false) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index eed795cdc..f134614cb 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -574,15 +574,16 @@ let make_elimination_ident id s = add_suffix id (elimination_suffix s) let lookup_eliminator ind_sp s = let kn,i = ind_sp in - let mp,dp,l = repr_kn kn in + let mp,dp,l = repr_mind kn in let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in let id = add_suffix ind_id (elimination_suffix s) in (* Try first to get an eliminator defined in the same section as the *) (* inductive type *) try - let cst = make_con mp dp (label_of_id id) in + let cst =Global.constant_of_delta + (make_con mp dp (label_of_id id)) in let _ = Global.lookup_constant cst in - mkConst cst + mkConst cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) (* using short name (e.g. for "eq_rec") *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index bfe1522f9..1f196f43e 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -471,5 +471,5 @@ let control_only_guard env c = iter env c let subst_inductive subst (kn,i as ind) = - let kn' = Mod_subst.subst_kn subst kn in + let kn' = Mod_subst.subst_ind subst kn in if kn == kn' then ind else (kn',i) diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index be37e6531..ec4a1260c 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -101,7 +101,7 @@ let rec pattern_of_constr t = | Prod (na,c,b) -> PProd (na,pattern_of_constr c,pattern_of_constr b) | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b) | App (f,a) -> PApp (pattern_of_constr f,Array.map pattern_of_constr a) - | Const sp -> PRef (ConstRef sp) + | Const sp -> PRef (ConstRef (constant_of_kn(canonical_con sp))) | Ind sp -> PRef (IndRef sp) | Construct sp -> PRef (ConstructRef sp) | Evar (n,ctxt) -> PEvar (n,Array.map pattern_of_constr ctxt) @@ -212,8 +212,9 @@ let rec pat_of_raw metas vars = function with Not_found -> PVar id) | RPatVar (_,(false,n)) -> metas := n::!metas; PMeta (Some n) - | RRef (_,r) -> - PRef r + | RRef (_,ConstRef con) -> + PRef (ConstRef (constant_of_kn(canonical_con con))) + | RRef (_,r) -> PRef r (* Hack pour ne pas réécrire une interprétation complčte des patterns*) | RApp (_, RPatVar (_,(true,n)), cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) @@ -295,5 +296,5 @@ and pat_of_raw_branch loc metas vars ind brs i = let pattern_of_rawconstr c = let metas = ref [] in - let p = pat_of_raw metas [] c in + let p = pat_of_raw metas [] c in (!metas,p) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 057b26394..13f2aef26 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -52,8 +52,8 @@ let load_structure i (_,(ind,id,kl,projs)) = let cache_structure o = load_structure 1 o -let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) = - let kn' = subst_kn subst kn in +let subst_structure (subst,((kn,i),id,kl,projs as obj)) = + let kn' = subst_ind subst kn in let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) @@ -136,7 +136,7 @@ let (in_method,out_method) = { (default_object "RECMETHODS") with load_function = (fun _ -> load_method); cache_function = load_method; - subst_function = (fun (_,s,(ty,id)) -> Mod_subst.subst_mps s ty,subst_id s id); + subst_function = (fun (s,(ty,id)) -> Mod_subst.subst_mps s ty,subst_id s id); classify_function = (fun x -> Substitute x) } @@ -252,7 +252,7 @@ let open_canonical_structure i (_,o) = let cache_canonical_structure o = open_canonical_structure 1 o -let subst_canonical_structure (_,subst,(cst,ind as obj)) = +let subst_canonical_structure (subst,(cst,ind as obj)) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) let cst' = fst (subst_con subst cst) in diff --git a/pretyping/termops.ml b/pretyping/termops.ml index f0a7ce4c8..3b6d13d47 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -65,9 +65,9 @@ let rec pr_constr c = match kind_of_term c with (str"Evar#" ++ int e ++ str"{" ++ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}") | Const c -> str"Cst(" ++ pr_con c ++ str")" - | Ind (sp,i) -> str"Ind(" ++ pr_path sp ++ str"," ++ int i ++ str")" + | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")" | Construct ((sp,i),j) -> - str"Constr(" ++ pr_path sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" + str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" | Case (ci,p,c,bl) -> v 0 (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++ pr_constr c ++ str"of") ++ cut() ++ @@ -729,7 +729,7 @@ let hdchar env c = lowercase_first_char (id_of_label (con_label kn)) | Ind ((kn,i) as x) -> if i=0 then - lowercase_first_char (id_of_label (label kn)) + lowercase_first_char (id_of_label (mind_label kn)) else lowercase_first_char (basename_of_global (IndRef x)) | Construct ((sp,i) as x) -> @@ -825,15 +825,22 @@ let names_of_rel_context env = (**** Globality of identifiers *) -let rec is_imported_modpath = function - | MPfile dp -> true - | p -> false +let rec is_imported_modpath mp = + let current_mp,_ = Lib.current_prefix() in + match mp with + | MPfile dp -> + let rec find_prefix = function + |MPfile dp1 -> not (dp1=dp) + |MPdot(mp,_) -> find_prefix mp + |MPbound(_) -> false + in find_prefix current_mp + | p -> false let is_imported_ref = function | VarRef _ -> false | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - let (mp,_,_) = repr_kn kn in is_imported_modpath mp + let (mp,_,_) = repr_mind kn in is_imported_modpath mp | ConstRef kn -> let (mp,_,_) = repr_con kn in is_imported_modpath mp diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 9d3522573..539821403 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -111,7 +111,7 @@ let load_class (_, cl) = let cache_class = load_class -let subst_class (_,subst,cl) = +let subst_class (subst,cl) = let do_subst_con c = fst (Mod_subst.subst_con subst c) and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in @@ -187,8 +187,9 @@ let load_instance (_,inst) = instances := Gmap.add inst.is_class insts !instances let cache_instance = load_instance -let subst_instance (_,subst,inst) = - { inst with + +let subst_instance (subst,inst) = + { inst with is_class = fst (subst_global subst inst.is_class); is_impl = fst (Mod_subst.subst_con subst inst.is_impl) } diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index d12b5f8e5..de1e3d2bd 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -51,7 +51,7 @@ let cache_strategy (_,str) = (fun (lev,ql) -> List.iter (fun q -> set_strategy_one q lev) ql) str -let subst_strategy (_,subs,(local,obj)) = +let subst_strategy (subs,(local,obj)) = local, list_smartmap (fun (k,ql as entry) -> diff --git a/tactics/auto.ml b/tactics/auto.ml index 9cdbc6627..fafc0b592 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -89,28 +89,30 @@ let insert v l = type stored_data = pri_auto_tactic -type search_entry = stored_data list * stored_data list * stored_data Btermdn.t +module Bounded_net = Btermdn.Make(struct + type t = stored_data + let compare = Pervasives.compare + end) -let empty_se = ([],[],Btermdn.create ()) +type search_entry = stored_data list * stored_data list * Bounded_net.t + +let empty_se = ([],[],Bounded_net.create ()) let add_tac pat t st (l,l',dn) = match pat with | None -> if not (List.mem t l) then (insert t l, l', dn) else (l, l', dn) - | Some pat -> if not (List.mem t l') then (l, insert t l', Btermdn.add st dn (pat,t)) else (l, l', dn) + | Some pat -> if not (List.mem t l') then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn) let rebuild_dn st (l,l',dn) = - (l, l', List.fold_left (fun dn t -> Btermdn.add (Some st) dn (Option.get t.pat, t)) - (Btermdn.create ()) l') + (l, l', List.fold_left (fun dn t -> Bounded_net.add (Some st) dn (Option.get t.pat, t)) + (Bounded_net.create ()) l') let lookup_tacs (hdc,c) st (l,l',dn) = - let l' = List.map snd (Btermdn.lookup st dn c) in + let l' = List.map snd (Bounded_net.lookup st dn c) in let sl' = Sort.list pri_order l' in Sort.merge pri_order l sl' -module Constr_map = Map.Make(struct - type t = global_reference - let compare = Pervasives.compare - end) +module Constr_map = Map.Make(RefOrdered) let is_transparent_gr (ids, csts) = function | VarRef id -> Idpred.mem id ids @@ -389,14 +391,8 @@ let forward_subst_tactic = let set_extern_subst_tactic f = forward_subst_tactic := f -let subst_autohint (_,subst,(local,name,hintlist as obj)) = +let subst_autohint (subst,(local,name,hintlist as obj)) = let trans_clenv clenv = Clenv.subst_clenv subst clenv in - let trans_data data code = - { data with - pat = Option.smartmap (subst_pattern subst) data.pat ; - code = code ; - } - in let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = @@ -409,29 +405,49 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = let data' = match data.code with | Res_pf (c, clenv) -> let c' = subst_mps subst c in - if c==c' then data else - trans_data data (Res_pf (c', trans_clenv clenv)) + let clenv' = trans_clenv clenv in + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && clenv'==clenv && pat'==data.pat then data else + {data with + pat=pat'; + code=Res_pf (c', clenv')} | ERes_pf (c, clenv) -> let c' = subst_mps subst c in - if c==c' then data else - trans_data data (ERes_pf (c', trans_clenv clenv)) + let clenv' = trans_clenv clenv in + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && clenv'==clenv && pat'==data.pat then data else + {data with + pat=pat'; + code=ERes_pf (c', clenv')} | Give_exact c -> let c' = subst_mps subst c in - if c==c' then data else - trans_data data (Give_exact c') + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && pat'==data.pat then data else + {data with + pat=pat'; + code=(Give_exact c')} | Res_pf_THEN_trivial_fail (c, clenv) -> let c' = subst_mps subst c in - if c==c' then data else - let code' = Res_pf_THEN_trivial_fail (c', trans_clenv clenv) in - trans_data data code' + let clenv' = trans_clenv clenv in + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if c==c' && clenv'==clenv && pat'==data.pat then data else + {data with + pat=pat'; + code=Res_pf_THEN_trivial_fail (c',clenv')} | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in - if ref==ref' then data else - trans_data data (Unfold_nth ref') + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if ref==ref' && pat'==data.pat then data else + {data with + pat=pat'; + code=(Unfold_nth ref')} | Extern tac -> let tac' = !forward_subst_tactic subst tac in - if tac==tac' then data else - trans_data data (Extern tac') + let pat' = Option.smartmap (subst_pattern subst) data.pat in + if tac==tac' && pat'==data.pat then data else + {data with + pat=pat'; + code=(Extern tac')} in if k' == k && data' == data then hint else (k',data') diff --git a/tactics/auto.mli b/tactics/auto.mli index 1910bd139..83ad60bc3 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -42,7 +42,7 @@ type pri_auto_tactic = { type stored_data = pri_auto_tactic -type search_entry = stored_data list * stored_data list * stored_data Btermdn.t +type search_entry (* The head may not be bound. *) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 6abe8938c..db0bbd867 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -215,7 +215,8 @@ let cache_hintrewrite (_,(rbase,lrl)) = let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab -let subst_hintrewrite (_,subst,(rbase,list as node)) = + +let subst_hintrewrite (subst,(rbase,list as node)) = let list' = HintDN.subst subst list in if list' == list then node else (rbase,list') diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index e28a9e3c3..198ee7859 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -20,71 +20,133 @@ open Libnames let dnet_depth = ref 8 -let bounded_constr_pat_discr_st st (t,depth) = - if depth = 0 then - None - else - match constr_pat_discr_st st t with - | None -> None - | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -let bounded_constr_val_discr_st st (t,depth) = - if depth = 0 then - Dn.Nothing - else - match constr_val_discr_st st t with - | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) - | Dn.Nothing -> Dn.Nothing - | Dn.Everything -> Dn.Everything +module Make = + functor (Z : Map.OrderedType) -> +struct + module Term_dn = Termdn.Make(Z) -let bounded_constr_pat_discr (t,depth) = - if depth = 0 then - None - else - match constr_pat_discr t with - | None -> None - | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + module X = struct + type t = constr_pattern*int + let compare = Pervasives.compare + end -let bounded_constr_val_discr (t,depth) = - if depth = 0 then - Dn.Nothing - else - match constr_val_discr t with - | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) - | Dn.Nothing -> Dn.Nothing - | Dn.Everything -> Dn.Everything + module Y = struct + type t = Term_dn.term_label + let compare x y = + let make_name n = + match n with + | Term_dn.GRLabel(ConstRef con) -> + Term_dn.GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | Term_dn.GRLabel(IndRef (kn,i)) -> + Term_dn.GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | Term_dn.GRLabel(ConstructRef ((kn,i),j ))-> + Term_dn.GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + module Dn = Dn.Make(X)(Y)(Z) + + type t = Dn.t -type 'a t = (term_label,constr_pattern * int,'a) Dn.t + let create = Dn.create -let create = Dn.create + let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] -let add = function - | None -> - (fun dn (c,v) -> - Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | _ -> Dn.Nothing -let rmv = function - | None -> - (fun dn (c,v) -> - Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) +let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) + | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) + | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) + | Sort s -> Dn.Label(Term_dn.SortLabel (Some s), []) + | Evar _ -> Dn.Everything + | _ -> Dn.Nothing -let lookup = function - | None -> - (fun dn t -> - List.map - (fun ((c,_),v) -> (c,v)) - (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))) - | Some st -> - (fun dn t -> - List.map - (fun ((c,_),v) -> (c,v)) - (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth))) - -let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn + let bounded_constr_pat_discr_st st (t,depth) = + if depth = 0 then + None + else + match Term_dn.constr_pat_discr_st st t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr_st st (t,depth) = + if depth = 0 then + Dn.Nothing + else + match constr_val_discr_st st t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + let bounded_constr_pat_discr (t,depth) = + if depth = 0 then + None + else + match Term_dn.constr_pat_discr t with + | None -> None + | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) + + let bounded_constr_val_discr (t,depth) = + if depth = 0 then + Dn.Nothing + else + match constr_val_discr t with + | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) + | Dn.Nothing -> Dn.Nothing + | Dn.Everything -> Dn.Everything + + + let add = function + | None -> + (fun dn (c,v) -> + Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) + | Some st -> + (fun dn (c,v) -> + Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + + let rmv = function + | None -> + (fun dn (c,v) -> + Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) + | Some st -> + (fun dn (c,v) -> + Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + + let lookup = function + | None -> + (fun dn t -> + List.map + (fun ((c,_),v) -> (c,v)) + (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))) + | Some st -> + (fun dn t -> + List.map + (fun ((c,_),v) -> (c,v)) + (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth))) + + let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn + +end + diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index b41ecbf77..ebded23ac 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -15,15 +15,19 @@ open Names (*i*) (* Discrimination nets with bounded depth. *) +module Make : + functor (Z : Map.OrderedType) -> +sig + type t -type 'a t + val create : unit -> t -val create : unit -> 'a t - -val add : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t -val rmv : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t - -val lookup : transparent_state option -> 'a t -> constr -> (constr_pattern * 'a) list -val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit + val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t + val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t + val lookup : transparent_state option -> t -> constr -> (constr_pattern * Z.t) list + val app : ((constr_pattern * Z.t) -> unit) -> t -> unit +end + val dnet_depth : int ref + diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli index 08d97646e..bd0859382 100644 --- a/tactics/decl_interp.mli +++ b/tactics/decl_interp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id:$ *) +(* $Id$ *) open Tacinterp open Decl_expr diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 07086e05a..96d83b972 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -157,35 +157,44 @@ let subst_located_destructor_pattern subst = function | ConclLocation d -> ConclLocation (subst_destructor_pattern subst d) + type destructor_data = { d_pat : located_destructor_pattern; d_pri : int; d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *) } -type t = (identifier,destructor_data) Nbtermdn.t -type frozen_t = (identifier,destructor_data) Nbtermdn.frozen_t +module Dest_data = struct + type t = destructor_data + let compare = Pervasives.compare + end + +module Nbterm_net = Nbtermdn.Make(Dest_data) + +type t = identifier Nbterm_net.t +type frozen_t = identifier Nbterm_net.frozen_t + +let tactab = (Nbterm_net.create () : t) -let tactab = (Nbtermdn.create () : t) +let lookup pat = Nbterm_net.lookup tactab pat -let lookup pat = Nbtermdn.lookup tactab pat -let init () = Nbtermdn.empty tactab +let init () = Nbterm_net.empty tactab -let freeze () = Nbtermdn.freeze tactab -let unfreeze fs = Nbtermdn.unfreeze fs tactab +let freeze () = Nbterm_net.freeze tactab +let unfreeze fs = Nbterm_net.unfreeze fs tactab let add (na,dd) = let pat = match dd.d_pat with | HypLocation(_,p,_) -> p.d_typ | ConclLocation p -> p.d_typ in - if Nbtermdn.in_dn tactab na then begin + if Nbterm_net.in_dn tactab na then begin msgnl (str "Warning [Overriding Destructor Entry " ++ str (string_of_id na) ++ str"]"); - Nbtermdn.remap tactab na (pat,dd) + Nbterm_net.remap tactab na (pat,dd) end else - Nbtermdn.add tactab (na,(pat,dd)) + Nbterm_net.add tactab (na,(pat,dd)) let _ = Summary.declare_summary "destruct-hyp-concl" @@ -207,7 +216,7 @@ let cache_dd (_,(_,na,dd)) = let classify_dd (local,_,_ as o) = if local then Dispose else Substitute o -let subst_dd (_,subst,(local,na,dd)) = +let subst_dd (subst,(local,na,dd)) = (local,na, { d_pat = subst_located_destructor_pattern subst dd.d_pat; d_pri = dd.d_pri; diff --git a/tactics/dn.ml b/tactics/dn.ml index 359e3fe7f..8076e252c 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -1,100 +1,99 @@ -(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* $Id$ *) -(* This file implements the basic structure of what Chet called - ``discrimination nets''. If my understanding is right, it serves - to associate actions (for example, tactics) with a priority to term - patterns, so that if a hypothesis matches a pattern in the net, - then the associated tactic is applied. Discrimination nets are used - (only) to implement the tactics Auto, DHyp and Point. - A discrimination net is a tries structure, that is, a tree structure - specially conceived for searching patterns, like for example strings - --see the file Tlm.ml in the directory lib/util--. Here the tries - structure are used for looking for term patterns. - This module is then used in : - - termdn.ml (discrimination nets of terms); - - btermdn.ml (discrimination nets of terms with bounded depth, - used in the tactic auto); - - nbtermdn.ml (named discrimination nets with bounded depth, used - in the tactics Dhyp and Point). - Eduardo (4/8/97) *) -(* Definition of the basic structure *) - -type ('lbl,'pat) decompose_fun = 'pat -> ('lbl * 'pat list) option - -type 'res lookup_res = Label of 'res | Nothing | Everything - -type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res - -type ('lbl,'pat,'inf) t = (('lbl * int) option,'pat * 'inf) Tlm.t - -let create () = Tlm.empty - -(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in +module Make = + functor (X : Set.OrderedType) -> + functor (Y : Map.OrderedType) -> + functor (Z : Map.OrderedType) -> +struct + + module Y_tries = struct + type t = (Y.t * int) option + let compare x y = + match x,y with + None,None -> 0 + | Some (l,n),Some (l',n') -> + if (Y.compare l l') = 0 && n = n' then 0 + else Pervasives.compare x y + | a,b -> Pervasives.compare a b + end + module X_tries = struct + type t = X.t * Z.t + let compare (x1,x2) (y1,y2) = + if (X.compare x1 y1) = 0 && (Z.compare x2 y2)=0 then 0 + else Pervasives.compare (x1,x2) (y1,y2) + end + + module T = Tries.Make(X_tries)(Y_tries) + + type decompose_fun = X.t -> (Y.t * X.t list) option + + type 'res lookup_res = Label of 'res | Nothing | Everything + + type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res + + type t = T.t + + let create () = T.empty + +(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in prefix ordering, [dna] is the function returning the main node of a pattern *) -let path_of dna = - let rec path_of_deferred = function - | [] -> [] - | h::tl -> pathrec tl h - - and pathrec deferred t = - match dna t with - | None -> - None :: (path_of_deferred deferred) - | Some (lbl,[]) -> - (Some (lbl,0))::(path_of_deferred deferred) - | Some (lbl,(h::def_subl as v)) -> - (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h) - in - pathrec [] - -let tm_of tm lbl = - try [Tlm.map tm lbl, true] with Not_found -> [] - -let rec skip_arg n tm = - if n = 0 then [tm,true] - else - List.flatten - (List.map - (fun a -> match a with - | None -> skip_arg (pred n) (Tlm.map tm a) - | Some (lbl,m) -> - skip_arg (pred n + m) (Tlm.map tm a)) - (Tlm.dom tm)) - -let lookup tm dna t = - let rec lookrec t tm = - match dna t with - | Nothing -> tm_of tm None - | Label(lbl,v) -> - tm_of tm None@ - (List.fold_left - (fun l c -> + let path_of dna = + let rec path_of_deferred = function + | [] -> [] + | h::tl -> pathrec tl h + + and pathrec deferred t = + match dna t with + | None -> + None :: (path_of_deferred deferred) + | Some (lbl,[]) -> + (Some (lbl,0))::(path_of_deferred deferred) + | Some (lbl,(h::def_subl as v)) -> + (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h) + in + pathrec [] + + let tm_of tm lbl = + try [T.map tm lbl, true] with Not_found -> [] + + let rec skip_arg n tm = + if n = 0 then [tm,true] + else + List.flatten + (List.map + (fun a -> match a with + | None -> skip_arg (pred n) (T.map tm a) + | Some (lbl,m) -> + skip_arg (pred n + m) (T.map tm a)) + (T.dom tm)) + + let lookup tm dna t = + let rec lookrec t tm = + match dna t with + | Nothing -> tm_of tm None + | Label(lbl,v) -> + tm_of tm None@ + (List.fold_left + (fun l c -> List.flatten(List.map (fun (tm, b) -> - if b then lookrec c tm - else [tm,b]) l)) - (tm_of tm (Some(lbl,List.length v))) v) - | Everything -> skip_arg 1 tm - in - List.flatten (List.map (fun (tm,b) -> Tlm.xtract tm) (lookrec t tm)) - -let add tm dna (pat,inf) = - let p = path_of dna pat in Tlm.add tm (p,(pat,inf)) - -let rmv tm dna (pat,inf) = - let p = path_of dna pat in Tlm.rmv tm (p,(pat,inf)) - -let app f tm = Tlm.app (fun (_,p) -> f p) tm - + if b then lookrec c tm + else [tm,b]) l)) + (tm_of tm (Some(lbl,List.length v))) v) + | Everything -> skip_arg 1 tm + in + List.flatten (List.map (fun (tm,b) -> T.xtract tm) (lookrec t tm)) + + let add tm dna (pat,inf) = + let p = path_of dna pat in T.add tm (p,(pat,inf)) + + let rmv tm dna (pat,inf) = + let p = path_of dna pat in T.rmv tm (p,(pat,inf)) + + let app f tm = T.app (fun (_,p) -> f p) tm + +end + diff --git a/tactics/dn.mli b/tactics/dn.mli index b4b2e6c89..3cb52a565 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -1,46 +1,47 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(*i $Id$ i*) -(* Discrimination nets. *) -type ('lbl,'tree) decompose_fun = 'tree -> ('lbl * 'tree list) option -type ('lbl,'pat,'inf) t (* = (('lbl * int) option,'pat * 'inf) Tlm.t *) -val create : unit -> ('lbl,'pat,'inf) t -(* [add t f (tree,inf)] adds a structured object [tree] together with - the associated information [inf] to the table [t]; the function - [f] is used to translated [tree] into its prefix decomposition: [f] - must decompose any tree into a label characterizing its root node and - the list of its subtree *) -val add : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf - -> ('lbl,'pat,'inf) t +module Make : + functor (X : Set.OrderedType) -> + functor (Y : Map.OrderedType) -> + functor (Z : Map.OrderedType) -> +sig -val rmv : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf - -> ('lbl,'pat,'inf) t - -type 'res lookup_res = Label of 'res | Nothing | Everything - -type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res + type decompose_fun = X.t -> (Y.t * X.t list) option + + type t + val create : unit -> t + + (* [add t f (tree,inf)] adds a structured object [tree] together with + the associated information [inf] to the table [t]; the function + [f] is used to translated [tree] into its prefix decomposition: [f] + must decompose any tree into a label characterizing its root node and + the list of its subtree *) + + val add : t -> decompose_fun -> X.t * Z.t -> t + + val rmv : t -> decompose_fun -> X.t * Z.t -> t + + type 'res lookup_res = Label of 'res | Nothing | Everything + + type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res + (* [lookup t f tree] looks for trees (and their associated information) in table [t] such that the structured object [tree] matches against them; [f] is used to translated [tree] into its prefix decomposition: [f] must decompose any tree into a label characterizing its root node and the list of its subtree *) - -val lookup : ('lbl,'pat,'inf) t -> ('lbl,'term) lookup_fun -> 'term - -> ('pat * 'inf) list - -val app : (('pat * 'inf) -> unit) -> ('lbl,'pat,'inf) t -> unit - -val skip_arg : int -> ('lbl,'pat,'inf) t -> (('lbl,'pat,'inf) t * bool) list + + val lookup : t -> 'term lookup_fun -> 'term + -> (X.t * Z.t) list + + val app : ((X.t * Z.t) -> unit) -> t -> unit + + val skip_arg : int -> t -> (t * bool) list + +end diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 6ac35317c..58ab6dfa0 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -401,7 +401,7 @@ let cache_transitivity_lemma (_,(left,lem)) = else transitivity_right_table := lem :: !transitivity_right_table -let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_mps subst ref) +let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) let (inTransitivity,_) = declare_object {(default_object "TRANSITIVITY-STEPS") with diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml index 3fd5236a8..7d6e1c4c9 100644 --- a/tactics/nbtermdn.ml +++ b/tactics/nbtermdn.ml @@ -26,34 +26,64 @@ open Libnames (* The former comments are from Chet. See the module dn.ml for further explanations. Eduardo (5/8/97) *) - -type ('na,'a) t = { - mutable table : ('na,constr_pattern * 'a) Gmap.t; - mutable patterns : (Termdn.term_label option,'a Btermdn.t) Gmap.t } - -type ('na,'a) frozen_t = - ('na,constr_pattern * 'a) Gmap.t - * (Termdn.term_label option,'a Btermdn.t) Gmap.t +module Make = + functor (Y:Map.OrderedType) -> +struct + module X = struct + type t = constr_pattern*int + let compare = Pervasives.compare + end + + module Term_dn = Termdn.Make(Y) + open Term_dn + module Z = struct + type t = Term_dn.term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + module Dn = Dn.Make(X)(Z)(Y) + module Bounded_net = Btermdn.Make(Y) + + +type 'na t = { + mutable table : ('na,constr_pattern * Y.t) Gmap.t; + mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t } + + +type 'na frozen_t = + ('na,constr_pattern * Y.t) Gmap.t + * (Term_dn.term_label option, Bounded_net.t) Gmap.t let create () = { table = Gmap.empty; patterns = Gmap.empty } let get_dn dnm hkey = - try Gmap.find hkey dnm with Not_found -> Btermdn.create () + try Gmap.find hkey dnm with Not_found -> Bounded_net.create () let add dn (na,(pat,valu)) = - let hkey = Option.map fst (Termdn.constr_pat_discr pat) in + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in dn.table <- Gmap.add na (pat,valu) dn.table; let dnm = dn.patterns in - dn.patterns <- Gmap.add hkey (Btermdn.add None (get_dn dnm hkey) (pat,valu)) dnm + dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm let rmv dn na = let (pat,valu) = Gmap.find na dn.table in - let hkey = Option.map fst (Termdn.constr_pat_discr pat) in + let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in dn.table <- Gmap.remove na dn.table; let dnm = dn.patterns in - dn.patterns <- Gmap.add hkey (Btermdn.rmv None (get_dn dnm hkey) (pat,valu)) dnm + dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm let in_dn dn na = Gmap.mem na dn.table @@ -61,13 +91,43 @@ let remap ndn na (pat,valu) = rmv ndn na; add ndn (na,(pat,valu)) +let decomp = + let rec decrec acc c = match kind_of_term c with + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_,_) -> decrec acc c1 + | _ -> (c,acc) + in + decrec [] + + let constr_val_discr t = + let c, l = decomp t in + match kind_of_term c with + | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Const _ -> Dn.Everything + | _ -> Dn.Nothing + +let constr_val_discr_st (idpred,cpred) t = + let c, l = decomp t in + match kind_of_term c with + | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l) + | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l) + | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l) + | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) + | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) + | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) + | Sort s -> Dn.Label(Term_dn.SortLabel (Some s), []) + | Evar _ -> Dn.Everything + | _ -> Dn.Nothing + let lookup dn valu = let hkey = - match (Termdn.constr_val_discr valu) with + match (constr_val_discr valu) with | Dn.Label(l,_) -> Some l | _ -> None in - try Btermdn.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] + try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] let app f dn = Gmap.iter f dn.table @@ -85,4 +145,4 @@ let empty dn = let to2lists dn = (Gmap.to_list dn.table, Gmap.to_list dn.patterns) - +end diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli index e8279b76f..027ea5734 100644 --- a/tactics/nbtermdn.mli +++ b/tactics/nbtermdn.mli @@ -15,24 +15,37 @@ open Libnames (*i*) (* Named, bounded-depth, term-discrimination nets. *) - -type ('na,'a) t -type ('na,'a) frozen_t - -val create : unit -> ('na,'a) t - -val add : ('na,'a) t -> ('na * (constr_pattern * 'a)) -> unit -val rmv : ('na,'a) t -> 'na -> unit -val in_dn : ('na,'a) t -> 'na -> bool -val remap : ('na,'a) t -> 'na -> (constr_pattern * 'a) -> unit - -val lookup : ('na,'a) t -> constr -> (constr_pattern * 'a) list -val app : ('na -> (constr_pattern * 'a) -> unit) -> ('na,'a) t -> unit - -val dnet_depth : int ref - -val freeze : ('na,'a) t -> ('na,'a) frozen_t -val unfreeze : ('na,'a) frozen_t -> ('na,'a) t -> unit -val empty : ('na,'a) t -> unit -val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * - (Termdn.term_label option * 'a Btermdn.t) list +module Make : + functor (Y:Map.OrderedType) -> +sig + + module Term_dn : sig + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel of sorts option + end + + type 'na t + type 'na frozen_t + + val create : unit -> 'na t + + val add : 'na t -> ('na * (constr_pattern * Y.t)) -> unit + val rmv : 'na t -> 'na -> unit + val in_dn : 'na t -> 'na -> bool + val remap : 'na t -> 'na -> (constr_pattern * Y.t) -> unit + + val lookup : 'na t -> constr -> (constr_pattern * Y.t) list + val app : ('na -> (constr_pattern * Y.t) -> unit) -> 'na t -> unit + + val dnet_depth : int ref + + + val freeze : 'na t -> 'na frozen_t + val unfreeze : 'na frozen_t -> 'na t -> unit + val empty : 'na t -> unit + val to2lists : 'na t -> ('na * (constr_pattern * Y.t)) list * + (Term_dn.term_label option * Btermdn.Make(Y).t) list +end diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index a7d041323..10d2a026e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -2837,9 +2837,9 @@ let cache_md x = load_md 1 x let subst_kind subst id = match id with | NewTac _ -> id - | UpdateTac kn -> UpdateTac (Mod_subst.subst_kn subst kn) + | UpdateTac kn -> UpdateTac (subst_kn subst kn) -let subst_md (_,subst,defs) = +let subst_md (subst,defs) = List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs let (inMD,outMD) = diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 5084635e8..a2bc95044 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -20,14 +20,43 @@ open Nametab (* Discrimination nets of terms. See the module dn.ml for further explanations. Eduardo (5/8/97) *) +module Make = + functor (Z : Map.OrderedType) -> +struct -type term_label = + module X = struct + type t = constr_pattern + let compare = Pervasives.compare + end + +type term_label = | GRLabel of global_reference | ProdLabel | LambdaLabel | SortLabel of sorts option -type 'a t = (term_label,constr_pattern,'a) Dn.t + module Y = struct + type t = term_label + let compare x y = + let make_name n = + match n with + | GRLabel(ConstRef con) -> + GRLabel(ConstRef(constant_of_kn(canonical_con con))) + | GRLabel(IndRef (kn,i)) -> + GRLabel(IndRef(mind_of_kn(canonical_mind kn),i)) + | GRLabel(ConstructRef ((kn,i),j ))-> + GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j)) + | k -> k + in + Pervasives.compare (make_name x) (make_name y) + end + + + module Dn = Dn.Make(X)(Y)(Z) + + type t = Dn.t + + type 'a lookup_res = 'a Dn.lookup_res (*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*) @@ -109,3 +138,5 @@ let rmv dn st = Dn.rmv dn (constr_pat_discr_st st) let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t let app f dn = Dn.app f dn + +end diff --git a/tactics/termdn.mli b/tactics/termdn.mli index e60aea6b4..aea49b073 100644 --- a/tactics/termdn.mli +++ b/tactics/termdn.mli @@ -28,38 +28,45 @@ indicates which constants and variables can be considered as rigid. These dnets are able to cope with existential variables as well, which match [Everything]. *) -type 'a t - -val create : unit -> 'a t - -(* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *) - -val add : 'a t -> transparent_state -> (constr_pattern * 'a) -> 'a t - -val rmv : 'a t -> transparent_state -> (constr_pattern * 'a) -> 'a t - -(* [lookup t c] looks for patterns (with their action) matching term [c] *) - -val lookup : 'a t -> transparent_state -> constr -> (constr_pattern * 'a) list - -val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit - - -(*i*) -(* These are for Nbtermdn *) - -type term_label = - | GRLabel of global_reference - | ProdLabel - | LambdaLabel - | SortLabel of sorts option - -val constr_pat_discr_st : transparent_state -> - constr_pattern -> (term_label * constr_pattern list) option -val constr_val_discr_st : transparent_state -> - constr -> (term_label * constr list) Dn.lookup_res - -val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option -val constr_val_discr : constr -> (term_label * constr list) Dn.lookup_res - +module Make : + functor (Z : Map.OrderedType) -> +sig + + type t + + type 'a lookup_res + + val create : unit -> t + + (* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *) + + val add : t -> transparent_state -> (constr_pattern * Z.t) -> t + + val rmv : t -> transparent_state -> (constr_pattern * Z.t) -> t + + (* [lookup t c] looks for patterns (with their action) matching term [c] *) + + val lookup : t -> transparent_state -> constr -> (constr_pattern * Z.t) list + + val app : ((constr_pattern * Z.t) -> unit) -> t -> unit + + + (*i*) + (* These are for Nbtermdn *) + + type term_label = + | GRLabel of global_reference + | ProdLabel + | LambdaLabel + | SortLabel of sorts option + + val constr_pat_discr_st : transparent_state -> + constr_pattern -> (term_label * constr_pattern list) option + val constr_val_discr_st : transparent_state -> + constr -> (term_label * constr list) lookup_res + + val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option + val constr_val_discr : constr -> (term_label * constr list) lookup_res + (*i*) +end diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 3e025b032..5a21b9090 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -47,8 +47,8 @@ let rec deconstruct_type t = let l,r = decompose_prod t in (List.map (fun (_,b) -> b) (List.rev l))@[r] -let subst_in_constr (_,subst,(ind,const)) = - let ind' = (subst_kn subst (fst ind)),(snd ind) +let subst_in_constr (subst,(ind,const)) = + let ind' = (subst_ind subst (fst ind)),(snd ind) and const' = subst_mps subst const in ind',const' @@ -156,7 +156,7 @@ let make_eq_scheme sp = | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) | Cast (x,_,_) -> aux (kind_of_term x) a | App (x,newa) -> aux (kind_of_term x) newa - | Ind (sp',i) -> if sp=sp' then mkRel(eqA-nlist-i+nb_ind-1) + | Ind (sp',i) -> if eq_mind sp sp' then mkRel(eqA-nlist-i+nb_ind-1) else ( try let eq = find_eq_scheme (sp',i) and eqa = Array.map @@ -167,7 +167,7 @@ let make_eq_scheme sp = in if args = [||] then eq else mkApp (eq,Array.append (Array.map (fun x->lift lifti x) a) eqa) - with Not_found -> raise(EqNotFound (string_of_kn sp')) + with Not_found -> raise(EqNotFound (string_of_mind sp')) ) | Sort _ -> raise (EqUnknown "Sort" ) | Prod _ -> raise (EqUnknown "Prod" ) @@ -257,7 +257,7 @@ let make_eq_scheme sp = (mkArrow (mkFullInd (sp,i) 1) bb); cores.(i) <- make_one_eq i done; - if (string_of_mp (modpath sp ))="Coq.Init.Logic" + if (string_of_mp (mind_modpath sp ))="Coq.Init.Logic" then print_string "Logic time, do nothing.\n" else ( for i=0 to (nb_ind-1) do @@ -451,7 +451,7 @@ let eqI ind l = (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e = try find_eq_scheme ind with Not_found -> error - ("The boolean equality on "^(string_of_kn (fst ind))^" is needed."); + ("The boolean equality on "^(string_of_mind (fst ind))^" is needed."); in (if eA = [||] then e else mkApp(e,eA)) let compute_bl_goal ind lnamesparrec nparrec = @@ -556,7 +556,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). | App (c,ca) -> ( match (kind_of_term c) with | Ind (i1,i2) -> - if(string_of_label (label i1) = "eq") + if(string_of_label (mind_label i1) = "eq") then ( tclTHENSEQ ((do_replace_bl ind gls (!avoid) nparrec (ca.(2)) diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index 291ce7bb1..5e8c1a07f 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -13,7 +13,7 @@ open Mod_subst open Sign -val subst_in_constr : (object_name*substitution*(inductive*constr)) +val subst_in_constr : (substitution*(inductive*constr)) -> (inductive*constr) val compute_bl_goal : inductive -> rel_context -> int -> types diff --git a/toplevel/class.ml b/toplevel/class.ml index 3a3588743..0166b5213 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -169,7 +169,7 @@ let ident_key_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" | CL_CONST sp -> string_of_label (con_label sp) - | CL_IND (sp,_) -> string_of_label (label sp) + | CL_IND (sp,_) -> string_of_label (mind_label sp) | CL_SECVAR id -> string_of_id id (* coercion identité *) diff --git a/toplevel/command.ml b/toplevel/command.ml index b50bcca77..34afbbcd5 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -644,19 +644,20 @@ let _ = let declare_mutual_with_eliminations isrecord mie impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let (_,kn) = declare_mind isrecord mie in + let mind =Global.mind_of_delta (mind_of_kn kn) in list_iter_i (fun i (indimpls, constrimpls) -> - let ind = (kn,i) in - Autoinstance.search_declaration (IndRef ind); - maybe_declare_manual_implicits false (IndRef ind) indimpls; - list_iter_i - (fun j impls -> + let ind = (mind,i) in + Autoinstance.search_declaration (IndRef ind); + maybe_declare_manual_implicits false (IndRef ind) indimpls; + list_iter_i + (fun j impls -> (* Autoinstance.search_declaration (ConstructRef (ind,j));*) - maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) - constrimpls) + maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) + constrimpls) impls; if_verbose ppnl (minductive_message names); - if !elim_flag then declare_eliminations kn; - kn + if !elim_flag then declare_eliminations mind; + mind let build_mutual l finite = let indl,ntnl = List.split l in diff --git a/toplevel/libtypes.ml b/toplevel/libtypes.ml index e04480700..7a065ae02 100644 --- a/toplevel/libtypes.ml +++ b/toplevel/libtypes.ml @@ -9,7 +9,8 @@ open Term open Summary open Libobject - +open Libnames +open Names (* * Module construction *) @@ -18,14 +19,16 @@ let reduce c = Reductionops.head_unfold_under_prod (Auto.Hint_db.transparent_state (Auto.searchtable_map "typeclass_instances")) (Global.env()) Evd.empty c -module TypeDnet = Term_dnet.Make(struct - type t = Libnames.global_reference - let compare = Pervasives.compare - let subst s gr = fst (Libnames.subst_global s gr) - let constr_of = Global.type_of_global - end) +module TypeDnet = Term_dnet.Make + (struct + type t = Libnames.global_reference + let compare = RefOrdered.compare + let subst s gr = fst (Libnames.subst_global s gr) + let constr_of = Global.type_of_global + end) (struct let reduce = reduce - let direction = false end) + let direction = false + end) type result = Libnames.global_reference * (constr*existential_key) * Termops.subst @@ -70,7 +73,7 @@ let (input,output) = declare_object { (default_object "LIBTYPES") with load_function = (fun _ -> load); - subst_function = (fun (_,s,t) -> subst s t); + subst_function = (fun (s,t) -> subst s t); classify_function = (fun x -> Substitute x) } diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index d19a43c8d..8bb53b378 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -65,7 +65,7 @@ let cache_tactic_notation (_,(pa,pp)) = let subst_tactic_parule subst (key,n,p,(d,tac)) = (key,n,p,(d,Tacinterp.subst_tactic subst tac)) -let subst_tactic_notation (_,subst,(pa,pp)) = +let subst_tactic_notation (subst,(pa,pp)) = (subst_tactic_parule subst pa,pp) let (inTacticGrammar, outTacticGrammar) = @@ -676,7 +676,7 @@ let subst_parsing_rule subst x = x let subst_printing_rule subst x = x -let subst_syntax_extension (_,subst,(local,sy)) = +let subst_syntax_extension (subst,(local,sy)) = (local, List.map (fun (prec,ntn,gr,pp) -> (prec,ntn, subst_parsing_rule subst gr, subst_printing_rule subst pp)) sy) @@ -865,7 +865,7 @@ let cache_notation o = load_notation 1 o; open_notation 1 o -let subst_notation (_,subst,(lc,scope,pat,b,ndf)) = +let subst_notation (subst,(lc,scope,pat,b,ndf)) = (lc,scope,subst_interpretation subst pat,b,ndf) let classify_notation (local,_,_,_,_ as o) = @@ -1024,7 +1024,7 @@ let cache_scope_command o = load_scope_command 1 o; open_scope_command 1 o -let subst_scope_command (_,subst,(scope,o as x)) = match o with +let subst_scope_command (subst,(scope,o as x)) = match o with | ScopeClasses cl -> let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else scope, ScopeClasses cl' diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 367ae1567..ee4370305 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -309,7 +309,7 @@ let (inMLModule,outMLModule) = declare_object {(default_object "ML-MODULE") with load_function = (fun _ -> cache_ml_module_object); cache_function = cache_ml_module_object; - subst_function = (fun (_,_,o) -> o); + subst_function = (fun (_,o) -> o); classify_function = classify_ml_module_object } let declare_ml_modules local l = diff --git a/toplevel/search.ml b/toplevel/search.ml index 8457ef020..8f31134c7 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -57,22 +57,23 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = fn (VarRef id) env typ with Not_found -> (* we are in a section *) ()) | "CONSTANT" -> - let cst = constant_of_kn kn in + let cst = Global.constant_of_delta(constant_of_kn kn) in let typ = Typeops.type_of_constant env cst in if refopt = None || head_const typ = constr_of_global (Option.get refopt) then fn (ConstRef cst) env typ | "INDUCTIVE" -> - let mib = Global.lookup_mind kn in + let mind = Global.mind_of_delta(mind_of_kn kn) in + let mib = Global.lookup_mind mind in (match refopt with - | Some (IndRef ((kn',tyi) as ind)) when kn=kn' -> + | Some (IndRef ((kn',tyi) as ind)) when eq_mind mind kn' -> print_constructors ind fn env (Array.length (mib.mind_packets.(tyi).mind_user_lc)) | Some _ -> () | _ -> Array.iteri - (fun i mip -> print_constructors (kn,i) fn env + (fun i mip -> print_constructors (mind,i) fn env (Array.length mip.mind_user_lc)) mib.mind_packets) | _ -> () in @@ -118,7 +119,7 @@ let filter_by_module (module_list:dir_path list) (accept:bool) with No_full_path -> false -let ref_eq = Libnames.encode_kn Coqlib.logic_module (id_of_string "eq"), 0 +let ref_eq = Libnames.encode_mind Coqlib.logic_module (id_of_string "eq"), 0 let c_eq = mkInd ref_eq let gref_eq = IndRef ref_eq diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index dac56e7d6..0d4168ec6 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -110,9 +110,9 @@ let uri_of_global ref = | ConstRef cst -> uri_of_repr_kn ref (repr_con cst); url_string ".con" | IndRef (kn,i) -> - uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1] + uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1] | ConstructRef ((kn,i),j) -> - uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1;j] + uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j] let whelm_special = id_of_string "WHELM_ANON_VAR" |