pmodule.ml 35 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

open Stdlib
open Ident
open Ty
15
open Term
Andrei Paskevich's avatar
Andrei Paskevich committed
16
open Decl
17 18 19
open Theory
open Ity
open Expr
20
open Pdecl
21 22 23 24 25 26 27 28 29 30

(** *)

type prog_symbol =
  | PV of pvsymbol
  | RS of rsymbol

type namespace = {
  ns_ts : itysymbol   Mstr.t;  (* type symbols *)
  ns_ps : prog_symbol Mstr.t;  (* program symbols *)
31
  ns_xs : xsymbol     Mstr.t;  (* exception symbols *)
32 33 34 35 36 37
  ns_ns : namespace   Mstr.t;  (* inner namespaces *)
}

let empty_ns = {
  ns_ts = Mstr.empty;
  ns_ps = Mstr.empty;
38
  ns_xs = Mstr.empty;
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59
  ns_ns = Mstr.empty;
}

let ns_replace eq chk x vo vn =
  if not chk then vn else
  if eq vo vn then vn else
  raise (ClashSymbol x)

let psym_equal p1 p2 = match p1,p2 with
  | PV p1, PV p2 -> pv_equal p1 p2
  | RS p1, RS p2 -> rs_equal p1 p2
  | _, _ -> false

let rec merge_ns chk ns1 ns2 =
  if ns1 == ns2 then ns1 else
  let join eq x n o = Some (ns_replace eq chk x o n) in
  let ns_union eq m1 m2 =
    if m1 == m2 then m1 else Mstr.union (join eq) m1 m2 in
  let fusion _ ns1 ns2 = Some (merge_ns chk ns1 ns2) in
  { ns_ts = ns_union its_equal ns1.ns_ts ns2.ns_ts;
    ns_ps = ns_union psym_equal ns1.ns_ps ns2.ns_ps;
60
    ns_xs = ns_union xs_equal ns1.ns_xs ns2.ns_xs;
61 62 63 64 65 66 67 68 69 70
    ns_ns = Mstr.union fusion ns1.ns_ns ns2.ns_ns; }

let add_ns chk x ns m = Mstr.change (function
  | Some os -> Some (merge_ns chk ns os)
  | None    -> Some ns) x m

let ns_add eq chk x vn m = Mstr.change (function
  | Some vo -> Some (ns_replace eq chk x vo vn)
  | None    -> Some vn) x m

71
let add_xs chk x xs ns = { ns with ns_xs = ns_add xs_equal   chk x xs ns.ns_xs }
72
let add_ts chk x ts ns = { ns with ns_ts = ns_add its_equal  chk x ts ns.ns_ts }
73
let add_ps chk x ps ns = { ns with ns_ps = ns_add psym_equal chk x ps ns.ns_ps }
74 75 76 77 78 79 80 81 82
let add_ns chk x nn ns = { ns with ns_ns = add_ns            chk x nn ns.ns_ns }

let rec ns_find get_map ns = function
  | []   -> assert false
  | [a]  -> Mstr.find a (get_map ns)
  | a::l -> ns_find get_map (Mstr.find a ns.ns_ns) l

let ns_find_prog_symbol = ns_find (fun ns -> ns.ns_ps)
let ns_find_ns          = ns_find (fun ns -> ns.ns_ns)
83
let ns_find_xs          = ns_find (fun ns -> ns.ns_xs)
84 85 86 87 88 89 90 91 92 93
let ns_find_its         = ns_find (fun ns -> ns.ns_ts)

let ns_find_pv ns s = match ns_find_prog_symbol ns s with
  | PV pv -> pv | _ -> raise Not_found

let ns_find_rs ns s = match ns_find_prog_symbol ns s with
  | RS rs -> rs | _ -> raise Not_found

(** {2 Module} *)

94
type pmodule = {
Andrei Paskevich's avatar
Andrei Paskevich committed
95 96 97 98 99 100 101 102 103 104 105
  mod_theory : theory;        (* pure theory *)
  mod_units  : mod_unit list; (* module declarations *)
  mod_export : namespace;     (* exported namespace *)
  mod_known  : known_map;     (* known identifiers *)
  mod_local  : Sid.t;         (* locally declared idents *)
  mod_used   : Sid.t;         (* used modules *)
}

and mod_unit =
  | Udecl  of pdecl
  | Uuse   of pmodule
Andrei Paskevich's avatar
Andrei Paskevich committed
106
  | Uclone of mod_inst
Andrei Paskevich's avatar
Andrei Paskevich committed
107 108 109
  | Umeta  of meta * meta_arg list
  | Uscope of string * bool * mod_unit list

Andrei Paskevich's avatar
Andrei Paskevich committed
110
and mod_inst = {
Andrei Paskevich's avatar
Andrei Paskevich committed
111
  mi_mod : pmodule;
112 113
  mi_ty  : ity Mts.t;
  mi_ts  : itysymbol Mts.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
114 115
  mi_ls  : lsymbol Mls.t;
  mi_pr  : prsymbol Mpr.t;
116
  mi_pv  : pvsymbol Mvs.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
117 118
  mi_rs  : rsymbol Mrs.t;
  mi_xs  : xsymbol Mexn.t;
119 120 121 122
}

(** {2 Module under construction} *)

123
type pmodule_uc = {
124
  muc_theory : theory_uc;
Andrei Paskevich's avatar
Andrei Paskevich committed
125
  muc_units  : mod_unit list;
126 127 128 129 130 131 132 133 134 135
  muc_import : namespace list;
  muc_export : namespace list;
  muc_known  : known_map;
  muc_local  : Sid.t;
  muc_used   : Sid.t;
  muc_env    : Env.env option;
}

let empty_module env n p = {
  muc_theory = create_theory ~path:p n;
Andrei Paskevich's avatar
Andrei Paskevich committed
136
  muc_units  = [];
137 138 139 140 141 142 143 144 145 146 147 148 149
  muc_import = [empty_ns];
  muc_export = [empty_ns];
  muc_known  = Mid.empty;
  muc_local  = Sid.empty;
  muc_used   = Sid.empty;
  muc_env    = env;
}

let close_module, restore_module =
  let h = Hid.create 17 in
  (fun uc ->
     let th = close_theory uc.muc_theory in (* catches errors *)
     let m = { mod_theory = th;
Andrei Paskevich's avatar
Andrei Paskevich committed
150
               mod_units  = List.rev uc.muc_units;
151 152 153 154 155 156 157 158
               mod_export = List.hd uc.muc_export;
               mod_known  = uc.muc_known;
               mod_local  = uc.muc_local;
               mod_used   = uc.muc_used; } in
     Hid.add h th.th_name m;
     m),
  (fun th -> Hid.find h th.th_name)

159
let open_scope uc s = match uc.muc_import with
160
  | ns :: _ -> { uc with
161
      muc_theory = Theory.open_scope uc.muc_theory s;
Andrei Paskevich's avatar
Andrei Paskevich committed
162
      muc_units  = [Uscope (s, false, uc.muc_units)];
163 164 165 166
      muc_import =       ns :: uc.muc_import;
      muc_export = empty_ns :: uc.muc_export; }
  | [] -> assert false

167 168
let close_scope uc ~import =
  let th = Theory.close_scope uc.muc_theory ~import in
Andrei Paskevich's avatar
Andrei Paskevich committed
169
  match List.rev uc.muc_units, uc.muc_import, uc.muc_export with
Andrei Paskevich's avatar
Andrei Paskevich committed
170 171 172
  | [Uscope (_,_,ul1)], _ :: sti, _ :: ste -> (* empty scope *)
      { uc with muc_theory = th;  muc_units  = ul1;
                muc_import = sti; muc_export = ste; }
Andrei Paskevich's avatar
Andrei Paskevich committed
173
  | Uscope (s,_,ul1) :: ul0, _ :: i1 :: sti, e0 :: e1 :: ste ->
174 175 176 177 178
      let i1 = if import then merge_ns false e0 i1 else i1 in
      let _  = if import then merge_ns true  e0 e1 else e1 in
      let i1 = add_ns false s e0 i1 in
      let e1 = add_ns true  s e0 e1 in
      { uc with
179
          muc_theory = th;
Andrei Paskevich's avatar
Andrei Paskevich committed
180
          muc_units  = Uscope (s, import, ul0) :: ul1;
181 182
          muc_import = i1 :: sti;
          muc_export = e1 :: ste; }
Andrei Paskevich's avatar
Andrei Paskevich committed
183
  | _ -> assert false
184

Andrei Paskevich's avatar
Andrei Paskevich committed
185 186 187 188 189 190
let use_export uc ({mod_theory = mth} as m) =
  let th = Theory.use_export uc.muc_theory mth in
  let uc = if Sid.mem mth.th_name uc.muc_used then uc
    else { uc with
      muc_known = merge_known uc.muc_known m.mod_known;
      muc_used  = Sid.add mth.th_name uc.muc_used } in
191 192 193
  match uc.muc_import, uc.muc_export with
  | i0 :: sti, e0 :: ste -> { uc with
      muc_theory = th;
Andrei Paskevich's avatar
Andrei Paskevich committed
194 195 196
      muc_units  = Uuse m :: uc.muc_units;
      muc_import = merge_ns false m.mod_export i0 :: sti;
      muc_export = merge_ns true  m.mod_export e0 :: ste; }
197 198
  | _ -> assert false

Andrei Paskevich's avatar
Andrei Paskevich committed
199 200 201
let add_meta uc m al = { uc with
  muc_theory = Theory.add_meta uc.muc_theory m al;
  muc_units  = Umeta (m,al) :: uc.muc_units; }
202

203 204
let store_path, store_module, restore_path =
  let id_to_path = Wid.create 17 in
Andrei Paskevich's avatar
Andrei Paskevich committed
205
  let store_path {muc_theory = uc} path id =
206 207
    (* this symbol already belongs to some theory *)
    if Wid.mem id_to_path id then () else
Andrei Paskevich's avatar
Andrei Paskevich committed
208 209 210
    let prefix = List.rev (id.id_string :: path @ uc.uc_prefix) in
    Wid.set id_to_path id (uc.uc_path, uc.uc_name.id_string, prefix) in
  let store_module {mod_theory = {th_name = id} as th} =
211 212
    (* this symbol is already a module *)
    if Wid.mem id_to_path id then () else
Andrei Paskevich's avatar
Andrei Paskevich committed
213
    Wid.set id_to_path id (th.th_path, id.id_string, []) in
214 215 216 217 218 219 220 221
  let restore_path id = Wid.find id_to_path id in
  store_path, store_module, restore_path

let close_module uc =
  let m = close_module uc in
  store_module m;
  m

222 223 224 225 226 227 228 229 230
let count_regions {muc_known = kn} {pv_ity = ity} mr =
  let add_reg r mr = Mreg.change (fun n -> Some (n <> None)) r mr in
  let meet mr1 mr2 = Mreg.union (fun _ x y -> Some (x || y)) mr1 mr2 in
  let join mr1 mr2 = Mreg.union (fun _ _ _ -> Some true) mr1 mr2 in
  let rec down mr ity = if ity.ity_pure then mr else
    match ity.ity_node with
    | Ityreg r -> fields (add_reg r mr) r.reg_its r.reg_args r.reg_regs
    | Ityapp (s,tl,rl) -> fields mr s tl rl
    | Itypur (s,tl) -> fields mr s tl []
231
    | Ityvar _ -> assert false
232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
  and fields mr s tl rl = if s.its_privmut then mr else
    let add_arg isb v ity = ity_match isb (ity_var v) ity in
    let isb = List.fold_left2 add_arg isb_empty s.its_ts.ts_args tl in
    let isb = List.fold_left2 reg_match isb s.its_regions rl in
    let add_ity mr ity = down mr (ity_full_inst isb ity) in
    let add_proj mr f = add_ity mr f.rs_cty.cty_result in
    let add_field mr v = add_ity mr v.pv_ity in
    let d = find_its_defn kn s in
    if d.itd_constructors = [] then
      List.fold_left add_proj mr d.itd_fields
    else
      join mr (List.fold_left (fun mr c ->
        meet mr (List.fold_left add_field Mreg.empty c.rs_cty.cty_args))
        Mreg.empty d.itd_constructors) in
  down mr ity

248 249 250 251 252 253 254 255
let add_symbol add id v uc =
  store_path uc [] id;
  match uc.muc_import, uc.muc_export with
  | i0 :: sti, e0 :: ste -> { uc with
      muc_import = add false id.id_string v i0 :: sti;
      muc_export = add true  id.id_string v e0 :: ste }
  | _ -> assert false

256
let add_pdecl uc d =
257
  let uc = { uc with
Andrei Paskevich's avatar
Andrei Paskevich committed
258
    muc_units = Udecl d :: uc.muc_units;
259
    muc_known = known_add_decl uc.muc_known d;
260
    muc_local = Sid.union uc.muc_local d.pd_news } in
261
  let add_rs uc s = add_symbol add_ps s.rs_name (RS s) uc in
262 263 264 265 266 267 268 269 270 271
  let add_rs_noalias uc s = match s.rs_logic with
    | RLls _ | RLlemma ->
        let sv = s.rs_cty.cty_effect.eff_reads in
        let mr = Spv.fold (count_regions uc) sv Mreg.empty in
        Mreg.iter (fun _ n ->
          if n then Loc.errorm ?loc:s.rs_name.id_loc
            "The type of this function contains an alias") mr;
        add_rs uc s
    | _ -> add_rs uc s in
  let add_rd uc d = add_rs_noalias uc d.rec_sym in
272 273 274 275 276 277 278 279
  match d.pd_node with
  | PDtype tdl ->
      let add uc d =
        let uc = List.fold_left add_rs uc d.itd_fields in
        let uc = List.fold_left add_rs uc d.itd_constructors in
        add_symbol add_ts d.itd_its.its_ts.ts_name d.itd_its uc in
      List.fold_left add uc tdl
  | PDlet (LDvar (v,_)) -> add_symbol add_ps v.pv_vs.vs_name (PV v) uc
280 281
  | PDlet (LDsym (s,_)) -> add_rs_noalias uc s
  | PDlet (LDrec l) -> List.fold_left add_rd uc l
282
  | PDexn xs -> add_symbol add_xs xs.xs_name xs uc
283
  | PDpure -> uc
284 285 286 287

(** {2 Builtin symbols} *)

let builtin_module =
288 289 290 291 292 293
  let uc = empty_module None (id_fresh "BuiltIn") ["why3";"BuiltIn"] in
  let uc = add_pdecl uc pd_int in
  let uc = add_pdecl uc pd_real in
  let uc = add_pdecl uc pd_equ in
  let m = close_module uc in
  { m with mod_theory = builtin_theory }
294 295 296

let bool_module =
  let uc = empty_module None (id_fresh "Bool") ["why3";"Bool"] in
297 298 299
  let uc = add_pdecl uc pd_bool in
  let m = close_module uc in
  { m with mod_theory = bool_theory }
300 301 302 303

let highord_module =
  let uc = empty_module None (id_fresh "HighOrd") ["why3";"HighOrd"] in
  let uc = use_export uc bool_module in
304 305 306 307
  let uc = add_pdecl uc pd_func in
  let uc = add_pdecl uc pd_func_app in
  let m = close_module uc in
  { m with mod_theory = highord_theory }
308

309 310 311 312 313 314
let tuple_module = Hint.memo 17 (fun n ->
  let nm = "Tuple" ^ string_of_int n in
  let uc = empty_module None (id_fresh nm) ["why3";nm] in
  let uc = add_pdecl uc (pd_tuple n) in
  let m = close_module uc in
  { m with mod_theory = tuple_theory n })
315 316 317 318

let unit_module =
  let uc = empty_module None (id_fresh "Unit") ["why3";"Unit"] in
  let uc = use_export uc (tuple_module 0) in
319
  let td = create_alias_decl (id_fresh "unit") [] ity_unit in
Andrei Paskevich's avatar
Andrei Paskevich committed
320 321
  let pd = create_type_decl [td] in
  let uc = add_pdecl uc pd in
322
  let th = List.fold_left (add_decl ~warn:false) uc.muc_theory pd.pd_pure in
Andrei Paskevich's avatar
Andrei Paskevich committed
323
  close_module { uc with muc_theory = th }
324 325 326 327 328 329 330 331

let create_module env ?(path=[]) n =
  let m = empty_module (Some env) n path in
  let m = use_export m builtin_module in
  let m = use_export m bool_module in
  let m = use_export m unit_module in
  m

332
let add_pdecl ~vc uc d =
333 334 335 336 337 338 339
  let ids = Mid.set_diff d.pd_syms uc.muc_known in
  let uc = Sid.fold (fun id uc ->
    if id_equal id ts_func.ts_name then
      use_export uc highord_module
    else match is_ts_tuple_id id with
    | Some n -> use_export uc (tuple_module n)
    | None -> uc) ids uc in
340
  ignore vc; (* TODO *)
341
  let uc = add_pdecl uc d in
342
  let th = List.fold_left (add_decl ~warn:true) uc.muc_theory d.pd_pure in
343 344
  { uc with muc_theory = th }

Andrei Paskevich's avatar
Andrei Paskevich committed
345 346 347 348
(** {2 Cloning} *)

type clones = {
  cl_local : Sid.t;
349 350
  mutable ty_table : ity Mts.t;
  mutable ts_table : itysymbol Mts.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
351 352 353
  mutable ls_table : lsymbol Mls.t;
  mutable pr_table : prsymbol Mpr.t;
  mutable rn_table : region Mreg.t;
354
  mutable pv_table : pvsymbol Mvs.t;
Andrei Paskevich's avatar
Andrei Paskevich committed
355 356 357 358
  mutable rs_table : rsymbol Mrs.t;
  mutable xs_table : xsymbol Mexn.t;
}

359 360
let empty_clones m = {
  cl_local = m.mod_local;
361
  ty_table = Mts.empty;
Andrei Paskevich's avatar
Andrei Paskevich committed
362 363 364 365
  ts_table = Mts.empty;
  ls_table = Mls.empty;
  pr_table = Mpr.empty;
  rn_table = Mreg.empty;
366
  pv_table = Mvs.empty;
Andrei Paskevich's avatar
Andrei Paskevich committed
367 368 369 370 371 372
  rs_table = Mrs.empty;
  xs_table = Mexn.empty;
}

(* populate the clone structure *)

373
let rec sm_trans_ty tym tsm ty = match ty.ty_node with
374
  | Tyapp (s, tl) ->
375
      let tl = List.map (sm_trans_ty tym tsm) tl in
376
      begin match Mts.find_opt s tsm with
377 378
      | Some its -> ty_app its.its_ts tl
      | None -> begin match Mts.find_opt s tym with
379 380
      | Some ity -> ty_inst (ts_match_args s tl) (ty_of_ity ity)
      | None -> ty_app s tl
381
      end end
382 383
  | Tyvar _ -> ty

384
let cl_trans_ty cl ty = sm_trans_ty cl.ty_table cl.ts_table ty
385

386 387 388
let cl_find_its cl its =
  if not (Sid.mem its.its_ts.ts_name cl.cl_local) then its
  else Mts.find its.its_ts cl.ts_table
389

390 391 392
let cl_find_ts cl ts =
  if not (Sid.mem ts.ts_name cl.cl_local) then ts
  else (Mts.find ts cl.ts_table).its_ts
393 394 395 396 397 398 399 400

let rec cl_trans_ity cl ity = match ity.ity_node with
  | Ityreg r ->
      ity_reg (cl_trans_reg cl r)
  | Ityapp (s, tl, rl) ->
      let tl = List.map (cl_trans_ity cl) tl in
      let rl = List.map (cl_trans_reg cl) rl in
      begin match Mts.find_opt s.its_ts cl.ts_table with
401 402
      | Some its -> ity_app its tl rl
      | None -> begin match Mts.find_opt s.its_ts cl.ty_table with
403 404
      | Some ity -> ity_full_inst (its_match_regs s tl rl) ity
      | None -> ity_app s tl rl
405
      end end
406 407 408
  | Itypur (s, tl) ->
      let tl = List.map (cl_trans_ity cl) tl in
      begin match Mts.find_opt s.its_ts cl.ts_table with
409 410
      | Some its -> ity_pur its tl
      | None -> begin match Mts.find_opt s.its_ts cl.ty_table with
411 412
      | Some ity -> ity_full_inst (its_match_args s tl) (ity_purify ity)
      | None -> ity_pur s tl
413
      end end
Andrei Paskevich's avatar
Andrei Paskevich committed
414 415 416
  | Ityvar _ -> ity

and cl_trans_reg cl reg =
417 418 419 420 421
  (* FIXME: what about top-level non-instantiated regions?
     We cannot check in cl.cl_local to see if they are there.
     Instead, we should prefill cl.pv_table and cl.rn_table
     with all top-level pvsymbols (local or external) before
     descending into a let_defn. *)
Andrei Paskevich's avatar
Andrei Paskevich committed
422
  try Mreg.find reg cl.rn_table with Not_found ->
423 424 425
  let tl = List.map (cl_trans_ity cl) reg.reg_args in
  let rl = List.map (cl_trans_reg cl) reg.reg_regs in
  let r = match Mts.find_opt reg.reg_its.its_ts cl.ts_table with
426 427 428
    | Some its ->
        create_region (id_clone reg.reg_name) its tl rl
    | None -> begin match Mts.find_opt reg.reg_its.its_ts cl.ty_table with
429 430 431 432 433 434 435
    | Some {ity_node = Ityreg r} ->
        let sbs = its_match_regs reg.reg_its tl rl in
        let tl = List.map (ity_full_inst sbs) r.reg_args in
        let rl = List.map (reg_full_inst sbs) r.reg_regs in
        create_region (id_clone reg.reg_name) r.reg_its tl rl
    | Some _ -> assert false
    | None ->
436 437
        create_region (id_clone reg.reg_name) reg.reg_its tl rl
    end in
438 439
  cl.rn_table <- Mreg.add reg r cl.rn_table;
  r
Andrei Paskevich's avatar
Andrei Paskevich committed
440 441 442

let cl_find_ls cl ls =
  if not (Sid.mem ls.ls_name cl.cl_local) then ls
443
  else Mls.find ls cl.ls_table
Andrei Paskevich's avatar
Andrei Paskevich committed
444

445 446 447
let cl_trans_term cl mv t = t_gen_map (cl_trans_ty cl) (cl_find_ls cl) mv t

let cl_trans_fmla cl f = cl_trans_term cl Mvs.empty f (* for closed terms *)
Andrei Paskevich's avatar
Andrei Paskevich committed
448

Andrei Paskevich's avatar
Andrei Paskevich committed
449
let cl_find_pr cl pr =
Andrei Paskevich's avatar
Andrei Paskevich committed
450
  if not (Sid.mem pr.pr_name cl.cl_local) then pr
451
  else Mpr.find pr cl.pr_table
Andrei Paskevich's avatar
Andrei Paskevich committed
452

Andrei Paskevich's avatar
Andrei Paskevich committed
453
let cl_find_pv cl pv =
Andrei Paskevich's avatar
Andrei Paskevich committed
454
  if not (Sid.mem pv.pv_vs.vs_name cl.cl_local) then pv
455
  else Mvs.find pv.pv_vs cl.pv_table
Andrei Paskevich's avatar
Andrei Paskevich committed
456

Andrei Paskevich's avatar
Andrei Paskevich committed
457
let cl_find_rs cl rs =
Andrei Paskevich's avatar
Andrei Paskevich committed
458 459 460
  if not (Sid.mem rs.rs_name cl.cl_local) then rs
  else Mrs.find rs cl.rs_table

Andrei Paskevich's avatar
Andrei Paskevich committed
461
let cl_find_xs cl xs =
Andrei Paskevich's avatar
Andrei Paskevich committed
462 463 464
  if not (Sid.mem xs.xs_name cl.cl_local) then xs
  else Mexn.find xs cl.xs_table

Andrei Paskevich's avatar
Andrei Paskevich committed
465 466 467
let cl_clone_ls inst cl ls =
  if Mls.mem ls inst.inst_ls then raise (CannotInstantiate ls.ls_name);
  let constr = ls.ls_constr in
468
  let id = id_clone ls.ls_name in
Andrei Paskevich's avatar
Andrei Paskevich committed
469 470 471 472 473 474
  let at = List.map (cl_trans_ty cl) ls.ls_args in
  let vt = Opt.map (cl_trans_ty cl) ls.ls_value in
  let ls' = create_lsymbol ~constr id at vt in
  cl.ls_table <- Mls.add ls ls' cl.ls_table;
  ls'

475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495
let cl_init_ty cl ({ts_name = id} as ts) ty =
  let rec restore_ity ty = match ty.ty_node with
    | Tyapp (s,tl) ->
        ity_app_fresh (restore_its s) (List.map restore_ity tl)
    | Tyvar v -> ity_var v in
  let its = restore_its ts and ity = restore_ity ty in
  if not (Sid.mem id cl.cl_local) then raise (NonLocal id);
  let stv = Stv.of_list ts.ts_args in
  if not (Stv.subset (ity_freevars Stv.empty ity) stv) ||
     its_impure its || not ity.ity_pure then raise (BadInstance id);
  cl.ty_table <- Mts.add ts ity cl.ty_table

let cl_init_ts cl ({ts_name = id} as ts) ts' =
  let its = restore_its ts and its' = restore_its ts' in
  if not (Sid.mem id cl.cl_local) then raise (NonLocal id);
  if List.length ts.ts_args <> List.length ts'.ts_args ||
     its_impure its || its_impure its' then raise (BadInstance id);
  cl.ts_table <- Mts.add its.its_ts its' cl.ts_table

let cl_init_ls cl ({ls_name = id} as ls) ls' =
  if not (Sid.mem id cl.cl_local) then raise (NonLocal id);
Andrei Paskevich's avatar
Andrei Paskevich committed
496
  let mtch sb ty ty' = try ty_match sb ty' (cl_trans_ty cl ty)
497
    with TypeMismatch _ -> raise (BadInstance id) in
Andrei Paskevich's avatar
Andrei Paskevich committed
498
  let sbs = match ls.ls_value,ls'.ls_value with
Andrei Paskevich's avatar
Andrei Paskevich committed
499 500
    | Some ty, Some ty' -> mtch Mtv.empty ty ty'
    | None, None -> Mtv.empty
501
    | _ -> raise (BadInstance id) in
Andrei Paskevich's avatar
Andrei Paskevich committed
502
  ignore (try List.fold_left2 mtch sbs ls.ls_args ls'.ls_args
503
    with Invalid_argument _ -> raise (BadInstance id));
Andrei Paskevich's avatar
Andrei Paskevich committed
504 505
  cl.ls_table <- Mls.add ls ls' cl.ls_table

506 507 508 509 510 511 512 513 514 515
let cl_init_pr cl {pr_name = id} _ =
  if not (Sid.mem id cl.cl_local) then raise (NonLocal id)

let cl_init m inst =
  let cl = empty_clones m in
  Mts.iter (cl_init_ty cl) inst.inst_ty;
  Mts.iter (cl_init_ts cl) inst.inst_ts;
  Mls.iter (cl_init_ls cl) inst.inst_ls;
  Mpr.iter (cl_init_pr cl) inst.inst_pr;
  cl
Andrei Paskevich's avatar
Andrei Paskevich committed
516 517 518

(* clone declarations *)

Andrei Paskevich's avatar
Andrei Paskevich committed
519
let clone_decl inst cl uc d = match d.d_node with
520
  | Dtype _ | Ddata _ -> assert false (* impossible *)
Andrei Paskevich's avatar
Andrei Paskevich committed
521
  | Dparam ls ->
522
      if Mls.mem ls inst.inst_ls then uc else
Andrei Paskevich's avatar
Andrei Paskevich committed
523 524 525 526 527 528 529 530 531 532 533 534
      let d = create_param_decl (cl_clone_ls inst cl ls) in
      add_pdecl ~vc:false uc (create_pure_decl d)
  | Dlogic ldl ->
      let get_ls (ls,_) = ignore (cl_clone_ls inst cl ls) in
      let get_logic (_,ld) =
        Opt.get (ls_defn_of_axiom (cl_trans_fmla cl (ls_defn_axiom ld))) in
      List.iter get_ls ldl;
      let d = create_logic_decl (List.map get_logic ldl) in
      add_pdecl ~vc:false uc (create_pure_decl d)
  | Dind (s, idl) ->
      let get_ls (ls,_) = cl_clone_ls inst cl ls in
      let get_case (pr,f) =
535
        if Mpr.mem pr inst.inst_pr then raise (CannotInstantiate pr.pr_name);
Andrei Paskevich's avatar
Andrei Paskevich committed
536 537 538 539 540 541 542 543
        let pr' = create_prsymbol (id_clone pr.pr_name) in
        cl.pr_table <- Mpr.add pr pr' cl.pr_table;
        pr', cl_trans_fmla cl f in
      let get_ind ls (_,la) = ls, List.map get_case la in
      let lls = List.map get_ls idl in
      let d = create_ind_decl s (List.map2 get_ind lls idl) in
      add_pdecl ~vc:false uc (create_pure_decl d)
  | Dprop (k,pr,f) ->
Andrei Paskevich's avatar
Andrei Paskevich committed
544
      let skip, k' = match k, Mpr.find_opt pr inst.inst_pr with
545 546 547 548 549
        | Pgoal, _ -> true, Pgoal
        | Plemma, Some Pgoal -> true, Pgoal
        | Plemma, _ -> false, Plemma
        | Paxiom, Some k -> false, k
        | Paxiom, None -> false, Paxiom (* TODO: Plemma *) in
Andrei Paskevich's avatar
Andrei Paskevich committed
550
      if skip then uc else
Andrei Paskevich's avatar
Andrei Paskevich committed
551 552 553 554 555
      let pr' = create_prsymbol (id_clone pr.pr_name) in
      cl.pr_table <- Mpr.add pr pr' cl.pr_table;
      let d = create_prop_decl k' pr' (cl_trans_fmla cl f) in
      add_pdecl ~vc:false uc (create_pure_decl d)

556 557 558 559 560 561 562 563 564 565 566 567 568
let cl_save_rs cl s s' =
  cl.rs_table <- Mrs.add s s' cl.rs_table;
  begin match s.rs_field, s'.rs_field with
  | Some v, Some v' -> cl.pv_table <- Mvs.add v.pv_vs v' cl.pv_table
  | None, None -> ()
  | _ -> assert false
  end;
  match s.rs_logic, s'.rs_logic with
  | RLls s, RLls s' -> cl.ls_table <- Mls.add s s' cl.ls_table
  | RLlemma, RLlemma -> () (* TODO: update cl.pr_table? *)
  | RLnone, RLnone -> ()
  | _ -> assert false

569 570 571 572 573 574 575 576 577 578 579 580 581
let clone_type_decl inst cl tdl =
  let def =
    List.fold_left (fun m d -> Mits.add d.itd_its d m) Mits.empty tdl in
  let htd = Hits.create 5 in

  let rec visit alg ({its_ts = {ts_name = id} as ts} as s) d =
    if not (Hits.mem htd s) then
    let alg = Sits.add s alg in
    let id' = id_clone id in
    let cloned = Mts.mem ts inst.inst_ts || Mts.mem ts inst.inst_ty in
    let conv_pj v = create_pvsymbol
      (id_clone v.pv_vs.vs_name) ~ghost:v.pv_ghost (conv_ity alg v.pv_ity) in
    let save_itd itd =
582 583
      List.iter2 (cl_save_rs cl) d.itd_constructors itd.itd_constructors;
      List.iter2 (cl_save_rs cl) d.itd_fields itd.itd_fields;
584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631
      Hits.add htd s (Some itd) in
    (* alias *)
    if s.its_def <> None then begin
      if cloned then raise (CannotInstantiate id);
      let def = conv_ity alg (Opt.get s.its_def) in
      let itd = create_alias_decl id' ts.ts_args def in
      cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
      save_itd itd
    end else
    (* abstract *)
    if d.itd_fields = [] && d.itd_constructors = [] &&
                            d.itd_invariant = [] then begin
      if cloned then Hits.add htd s None else begin
        let itd = create_abstract_type_decl id' ts.ts_args s.its_privmut in
        cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
        save_itd itd
      end
    end else
    (* variant *)
    if s.its_mfields = [] && d.itd_constructors <> [] &&
                             d.itd_invariant = [] then begin
      if cloned then raise (CannotInstantiate id);
      let conv_fd m fd =
        let v = Opt.get fd.rs_field in Mpv.add v (conv_pj v) m in
      let fldm = List.fold_left conv_fd Mpv.empty d.itd_fields in
      let conv_pj pj = match Mpv.find_opt pj fldm with
        | Some pj' -> true, pj' | None -> false, conv_pj pj in
      let conv_cs cs =
        id_clone cs.rs_name, List.map conv_pj cs.rs_cty.cty_args in
      let csl = List.map conv_cs d.itd_constructors in
      match Mts.find_opt ts cl.ts_table with
      | Some s' ->
          let itd = create_rec_variant_decl s' csl in
          save_itd itd
      | None ->
          let itd = create_flat_variant_decl id' ts.ts_args csl in
          cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
          save_itd itd
    end else begin
    (* flat record *)
      if cloned then raise (CannotInstantiate id);
      let mfld = Spv.of_list s.its_mfields in
      let priv = d.itd_constructors = [] in
      let mut = its_mutable s in
      let pjl = List.map (fun fd -> Opt.get fd.rs_field) d.itd_fields in
      let fdl = List.map (fun v -> Spv.mem v mfld, conv_pj v) pjl in
      let inv =
        if d.itd_invariant = [] then [] else
632 633 634
        let add mv u (_,v) = Mvs.add u.pv_vs v.pv_vs mv in
        let mv = List.fold_left2 add Mvs.empty pjl fdl in
        List.map (cl_trans_term cl mv) d.itd_invariant in
635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657
      let itd = create_flat_record_decl id' ts.ts_args priv mut fdl inv in
      cl.ts_table <- Mts.add ts itd.itd_its cl.ts_table;
      save_itd itd
    end

  and conv_ity alg ity =
    let rec down ity = match ity.ity_node with
      | Ityreg {reg_its = s; reg_args = tl}
      | Ityapp (s,tl,_) | Itypur (s,tl) ->
          if Sits.mem s alg then begin
            if not (Mts.mem s.its_ts cl.ts_table) then
            let id = id_clone s.its_ts.ts_name in
            let s = create_itysymbol_pure id s.its_ts.ts_args in
            cl.ts_table <- Mts.add s.its_ts s cl.ts_table
          end else Opt.iter (visit alg s) (Mits.find_opt s def);
          List.iter down tl
      | Ityvar _ -> () in
    down ity;
    cl_trans_ity cl ity in

  Mits.iter (visit Sits.empty) def;
  Lists.map_filter (fun d -> Hits.find htd d.itd_its) tdl

658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680
type smap = {
  sm_vs : vsymbol Mvs.t;
  sm_pv : pvsymbol Mvs.t;
  sm_rs : rsymbol Mrs.t;
}

let sm_of_cl cl = {
  sm_vs = Mvs.map (fun v -> v.pv_vs) cl.pv_table;
  sm_pv = cl.pv_table;
  sm_rs = cl.rs_table }

let sm_save_pv sm v v' = {
  sm_vs = Mvs.add v.pv_vs v'.pv_vs sm.sm_vs;
  sm_pv = Mvs.add v.pv_vs v' sm.sm_pv;
  sm_rs = sm.sm_rs }

let sm_save_rs cl sm s s' =
  let sm = { sm with sm_rs = Mrs.add s s' sm.sm_rs } in
  match s.rs_logic, s'.rs_logic with
  | RLls s, RLls s' -> cl.ls_table <- Mls.add s s' cl.ls_table; sm
  | RLpv v, RLpv v' -> sm_save_pv sm v v'
  | _ -> sm

681 682 683
let sm_find_pv sm v = Mvs.find_def v v.pv_vs sm.sm_pv
  (* non-instantiated global variables are not in sm *)

684 685 686 687 688 689 690 691
let clone_varl cl sm varl = List.map (fun (t,r) ->
  cl_trans_term cl sm.sm_vs t, Opt.map (cl_find_ls cl) r) varl

let clone_cty cl sm cty =
  let conv_pv v = create_pvsymbol (id_clone v.pv_vs.vs_name)
      ~ghost:v.pv_ghost (cl_trans_ity cl v.pv_ity) in
  let args = List.map conv_pv cty.cty_args in
  let sm_args = List.fold_left2 sm_save_pv sm cty.cty_args args in
692 693
  let add_old o n (sm, olds) = let o' = conv_pv o in
    sm_save_pv sm o o', Mpv.add o' (sm_find_pv sm_args n) olds in
694 695 696 697 698 699
  let sm_olds, olds = Mpv.fold add_old cty.cty_oldies (sm_args, Mpv.empty) in
  let conv_pre tl = List.map (cl_trans_term cl sm_args.sm_vs) tl in
  let conv_post tl = List.map (cl_trans_term cl sm_olds.sm_vs) tl in
  let add_xpost xs tl q = Mexn.add (cl_find_xs cl xs) (conv_post tl) q in
  let pre = conv_pre cty.cty_pre and post = conv_post cty.cty_post in
  let xpost = Mexn.fold add_xpost cty.cty_xpost Mexn.empty in
700
  let add_read v s = Spv.add (sm_find_pv sm_args v) s in
701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720
  let reads = Spv.fold add_read cty.cty_effect.eff_reads Spv.empty in
  let reads = Mpv.fold (fun v _ s -> Spv.add v s) olds reads in
  let add_write reg fs m =
    let add_f f s = Spv.add (Mvs.find f.pv_vs cl.pv_table) s in
    Mreg.add (cl_trans_reg cl reg) (Spv.fold add_f fs Spv.empty) m in
  let writes = Mreg.fold add_write cty.cty_effect.eff_writes Mreg.empty in
  let add_reset reg s = Sreg.add (cl_trans_reg cl reg) s in
  let resets = Sreg.fold add_reset cty.cty_effect.eff_resets Sreg.empty in
  let eff = eff_reset (eff_write reads writes) resets in
  let eff = eff_ghostify cty.cty_effect.eff_ghost eff in
  let add_raise xs eff = eff_raise eff (cl_find_xs cl xs) in
  let eff = Sexn.fold add_raise cty.cty_effect.eff_raises eff in
  let eff = if cty.cty_effect.eff_oneway then eff_diverge eff else eff in
  let res = cl_trans_ity cl cty.cty_result in
  create_cty args pre post xpost olds eff res

let sm_save_args sm c c' =
  List.fold_left2 sm_save_pv sm c.cty_args c'.cty_args

let sm_save_olds sm c c' =
721 722
  let revs = Mpv.fold (fun o n m -> Mpv.add n o m) c'.cty_oldies Mpv.empty in
  let add_old o n sm = sm_save_pv sm o (Mpv.find (sm_find_pv sm n) revs) in
723 724 725 726 727 728 729 730 731 732
  Mpv.fold add_old c.cty_oldies sm

let rs_kind s = match s.rs_logic with
  | RLnone -> RKnone
  | RLpv _ -> RKlocal
  | RLls { ls_value = None } -> RKpred
  | RLls _ -> RKfunc
  | RLlemma -> RKlemma

let rec clone_expr cl sm e = e_label_copy e (match e.e_node with
733
  | Evar v -> e_var (sm_find_pv sm v)
734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757
  | Econst c -> e_const c
  | Eexec c -> e_exec (clone_cexp cl sm c)
  | Eassign _ ->
      assert false (* TODO *)
  | Elet (ld, e) ->
      let sm, ld = clone_let_defn cl sm ld in
      e_let ld (clone_expr cl sm e)
  | Eif (e1, e2, e3) ->
      e_if (clone_expr cl sm e1) (clone_expr cl sm e2) (clone_expr cl sm e3)
  | Ecase _ ->
      (* do not forget to e_ghostify the matched expr *)
      assert false (* TODO *)
  | Ewhile _ | Efor _ | Etry _ ->
      assert false (* TODO *)
  | Eraise (xs, e) ->
      e_raise (cl_find_xs cl xs) (clone_expr cl sm e) (cl_trans_ity cl e.e_ity)
  | Eassert (k, f) ->
      e_assert k (cl_trans_term cl sm.sm_vs f)
  | Epure t ->
      e_pure (cl_trans_term cl sm.sm_vs t)
  | Eabsurd -> e_absurd (cl_trans_ity cl e.e_ity))

and clone_cexp cl sm c = match c.c_node with
  | Capp (s,vl) ->
758
      let vl = List.map (fun v -> sm_find_pv sm v) vl in
759 760
      let al = List.map (fun v -> cl_trans_ity cl v.pv_ity) c.c_cty.cty_args in
      let res = cl_trans_ity cl c.c_cty.cty_result in
761
      c_app (Mrs.find_def s s sm.sm_rs) vl al res
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804
  | Cfun e ->
      let cty = clone_cty cl sm c.c_cty in
      let sm = sm_save_args sm c.c_cty cty in
      let sm = sm_save_olds sm c.c_cty cty in
      c_fun cty.cty_args cty.cty_pre cty.cty_post
        cty.cty_xpost cty.cty_oldies (clone_expr cl sm e)
  | Cany ->
      c_any (clone_cty cl sm c.c_cty)

and clone_let_defn cl sm ld = match ld with
  | LDvar (v,e) ->
      let e' = clone_expr cl sm e in
      let ld, v' = let_var (id_clone v.pv_vs.vs_name) ~ghost:v.pv_ghost e' in
      sm_save_pv sm v v', ld
  | LDsym (s,c) ->
      let c' = clone_cexp cl sm c in
      let ld, s' = let_sym (id_clone s.rs_name)
        ~ghost:(rs_ghost s) ~kind:(rs_kind s) c' in
      sm_save_rs cl sm s s', ld
  | LDrec rdl ->
      let conv_rs mrs {rec_rsym = rs} =
        let rs' = create_rsymbol (id_clone rs.rs_name)
          ~ghost:(rs_ghost rs) (clone_cty cl sm rs.rs_cty) in
        Mrs.add rs rs' mrs, rs' in
      let mrs, rsyml = Lists.map_fold_left conv_rs sm.sm_rs rdl in
      let rsm = { sm with sm_rs = mrs } in
      let conv_rd ({rec_fun = c} as rd) ({rs_cty = cty} as rs) =
        let pre = if rd.rec_varl = [] then cty.cty_pre
          else List.tl cty.cty_pre (* remove DECR *) in
        let rsm = sm_save_args rsm c.c_cty cty in
        let varl = clone_varl cl rsm rd.rec_varl in
        let rsm = sm_save_olds rsm c.c_cty cty in
        let e = match c.c_node with
          | Cfun e -> clone_expr cl rsm e
          | _ -> assert false (* can't be *) in
        let c = c_fun cty.cty_args pre
          cty.cty_post cty.cty_xpost cty.cty_oldies e in
        rs, c, varl, rs_kind rd.rec_sym in
      let ld, rdl' = let_rec (List.map2 conv_rd rdl rsyml) in
      let sm = List.fold_left2 (fun sm d d' ->
        sm_save_rs cl sm d.rec_sym d'.rec_sym) sm rdl rdl' in
      sm, ld

Andrei Paskevich's avatar
Andrei Paskevich committed
805
let clone_pdecl inst cl uc d = match d.pd_node with
806 807 808 809
  | PDtype tdl ->
      let tdl = clone_type_decl inst cl tdl in
      if tdl = [] then uc else
      add_pdecl ~vc:false uc (create_type_decl tdl)
810 811 812 813 814 815
  | PDlet ld ->
      let reads = match ld with
        | LDvar (_,e) -> e.e_effect.eff_reads
        | LDsym (_,c) -> cty_reads c.c_cty
        | LDrec rdl -> List.fold_left (fun spv {rec_rsym = s} ->
            Spv.union spv (cty_reads s.rs_cty)) Spv.empty rdl in
816 817 818
      let frz = Spv.fold (fun v isb ->
        if Sid.mem v.pv_vs.vs_name cl.cl_local then isb
        else ity_freeze isb v.pv_ity) reads isb_empty in
819
      cl.rn_table <- Mreg.set_union cl.rn_table frz.isb_reg;
820 821
      let sm, ld = clone_let_defn cl (sm_of_cl cl) ld in
      cl.pv_table <- sm.sm_pv; cl.rs_table <- sm.sm_rs;
822
      add_pdecl ~vc:false uc (create_let_decl ld)
Andrei Paskevich's avatar
Andrei Paskevich committed
823 824 825 826 827 828 829 830
  | PDexn xs ->
      let ity = cl_trans_ity cl xs.xs_ity in
      let xs' = create_xsymbol (id_clone xs.xs_name) ity in
      cl.xs_table <- Mexn.add xs xs' cl.xs_table;
      add_pdecl ~vc:false uc (create_exn_decl xs')
  | PDpure ->
      List.fold_left (clone_decl inst cl) uc d.pd_pure

Andrei Paskevich's avatar
Andrei Paskevich committed
831 832
let theory_add_clone = Theory.add_clone_internal ()

Andrei Paskevich's avatar
Andrei Paskevich committed
833
let add_clone uc mi =
834 835 836 837 838
  let sm = {
    sm_ty = Mts.map ty_of_ity mi.mi_ty;
    sm_ts = Mts.map (fun s -> s.its_ts) mi.mi_ts;
    sm_ls = mi.mi_ls;
    sm_pr = mi.mi_pr } in
Andrei Paskevich's avatar
Andrei Paskevich committed
839
  { uc with
840
      muc_theory = theory_add_clone uc.muc_theory mi.mi_mod.mod_theory sm;
Andrei Paskevich's avatar
Andrei Paskevich committed
841
      muc_units  = Uclone mi :: uc.muc_units }
Andrei Paskevich's avatar
Andrei Paskevich committed
842 843

let clone_export uc m inst =
844
  let cl = cl_init m inst in
Andrei Paskevich's avatar
Andrei Paskevich committed
845 846 847 848
  let rec add_unit uc u = match u with
    | Udecl d -> clone_pdecl inst cl uc d
    | Uuse m -> use_export uc m
    | Uclone mi ->
Andrei Paskevich's avatar
Andrei Paskevich committed
849
        begin try add_clone uc { mi_mod = mi.mi_mod;
850 851
          mi_ty = Mts.map (cl_trans_ity cl) mi.mi_ty;
          mi_ts = Mts.map (cl_find_its cl) mi.mi_ts;
Andrei Paskevich's avatar
Andrei Paskevich committed
852 853
          mi_ls = Mls.map (cl_find_ls cl) mi.mi_ls;
          mi_pr = Mpr.map (cl_find_pr cl) mi.mi_pr;
854
          mi_pv = Mvs.map (cl_find_pv cl) mi.mi_pv;
Andrei Paskevich's avatar
Andrei Paskevich committed
855 856
          mi_rs = Mrs.map (cl_find_rs cl) mi.mi_rs;
          mi_xs = Mexn.map (cl_find_xs cl) mi.mi_xs}
Andrei Paskevich's avatar
Andrei Paskevich committed
857
        with Not_found -> uc end
Andrei Paskevich's avatar
Andrei Paskevich committed
858
    | Umeta (m,al) ->
Andrei Paskevich's avatar
Andrei Paskevich committed
859
        begin try add_meta uc m (List.map (function
Andrei Paskevich's avatar
Andrei Paskevich committed
860 861 862 863
          | MAty ty -> MAty (cl_trans_ty cl ty)
          | MAts ts -> MAts (cl_find_ts cl ts)
          | MAls ls -> MAls (cl_find_ls cl ls)
          | MApr pr -> MApr (cl_find_pr cl pr)
Andrei Paskevich's avatar
Andrei Paskevich committed
864 865
          | a -> a) al)
        with Not_found -> uc end
Andrei Paskevich's avatar
Andrei Paskevich committed
866 867 868 869 870 871 872
    | Uscope (n,import,ul) ->
        let uc = open_scope uc n in
        let uc = List.fold_left add_unit uc ul in
        close_scope ~import uc in
  let uc = List.fold_left add_unit uc m.mod_units in
  let mi = {
    mi_mod = m;
873
    mi_ty  = cl.ty_table;
Andrei Paskevich's avatar
Andrei Paskevich committed
874 875 876 877 878 879 880 881
    mi_ts  = cl.ts_table;
    mi_ls  = cl.ls_table;
    mi_pr  = cl.pr_table;
    mi_pv  = cl.pv_table;
    mi_rs  = cl.rs_table;
    mi_xs  = cl.xs_table} in
  add_clone uc mi

882 883
(** {2 WhyML language} *)

884
type mlw_file = pmodule Mstr.t
885

886 887 888 889 890 891 892 893
let convert mm =
  let convert m = m.mod_theory in
  if Mstr.is_empty mm then Mstr.empty else
  match (snd (Mstr.choose mm)).mod_theory.th_path with
  | "why3" :: path ->
      begin try Env.base_language_builtin path
      with Not_found -> Mstr.map convert mm end
  | _ -> Mstr.map convert mm
894 895 896

let mlw_language = Env.register_language Env.base_language convert

897 898 899 900 901 902 903
module Hpath = Exthtbl.Make(struct
  type t = Env.pathname
  let hash = Hashtbl.hash
  let equal = (=)
end)

let mlw_language_builtin =
904 905 906 907 908 909 910 911
  let builtin s =
    if s = unit_module.mod_theory.th_name.id_string then unit_module else
    if s = builtin_theory.th_name.id_string then builtin_module else
    if s = highord_theory.th_name.id_string then highord_module else
    if s = bool_theory.th_name.id_string then bool_module else
    match tuple_theory_name s with
    | Some n -> tuple_module n
    | None -> raise Not_found in
912
  Hpath.memo 7 (function
913 914
    | [s] -> Mstr.singleton s (builtin s)
    | _   -> raise Not_found)
915

916 917
let () = Env.add_builtin mlw_language mlw_language_builtin

918 919 920 921
exception ModuleNotFound of Env.pathname * string

let read_module env path s =
  let path = if path = [] then ["why3"; s] else path in
922
  let mm = Env.read_library mlw_language env path in
923 924
  Mstr.find_exn (ModuleNotFound (path,s)) s mm

Andrei Paskevich's avatar
Andrei Paskevich committed
925 926
(* pretty-printing *)

927 928 929
let print_path fmt sl =
  Pp.print_list (Pp.constant_string ".") Format.pp_print_string fmt sl

Andrei Paskevich's avatar
Andrei Paskevich committed
930 931 932 933 934 935 936 937 938
let print_mname fmt {mod_theory = th} =
  List.iter (fun s ->
    Format.pp_print_string fmt s;
    Format.pp_print_char fmt '.') th.th_path;
  Format.pp_print_string fmt th.th_name.id_string

let rec print_unit fmt = function
  | Udecl d -> Pdecl.print_pdecl fmt d
  | Uuse m -> Format.fprintf fmt "use export %a" print_mname m
Andrei Paskevich's avatar
Andrei Paskevich committed
939
  | Uclone mi -> Format.fprintf fmt "clone export %a with ..."
Andrei Paskevich's avatar
Andrei Paskevich committed
940 941 942 943 944 945
      print_mname mi.mi_mod
  | Umeta (m,al) -> Format.fprintf fmt "@[<hov 2>meta %s %a@]"
      m.meta_name (Pp.print_list Pp.comma Pretty.print_meta_arg) al
  | Uscope (s,i,[Uuse m]) -> Format.fprintf fmt "use%s %a%s"
      (if i then " import" else "") print_mname m
      (if s = m.mod_theory.th_name.id_string then "" else " as " ^ s)
Andrei Paskevich's avatar
Andrei Paskevich committed
946
  | Uscope (s,i,[Uclone mi]) -> Format.fprintf fmt "clone%s %a%s with ..."
Andrei Paskevich's avatar
Andrei Paskevich committed
947 948 949 950 951 952 953 954 955
      (if i then " import" else "") print_mname mi.mi_mod
      (if s = mi.mi_mod.mod_theory.th_name.id_string then "" else " as " ^ s)
  | Uscope (s,i,ul) -> Format.fprintf fmt "@[<hov 2>scope%s %s@\n%a@]@\nend"
      (if i then " import" else "") s (Pp.print_list Pp.newline2 print_unit) ul

let print_module fmt m = Format.fprintf fmt
  "@[<hov 2>module %s@\n%a@]@\nend" m.mod_theory.th_name.id_string
  (Pp.print_list Pp.newline2 print_unit) m.mod_units

956 957 958 959
let () = Exn_printer.register (fun fmt e -> match e with
  | ModuleNotFound (sl,s) -> Format.fprintf fmt
      "Module %s not found in library %a" s print_path sl
  | _ -> raise e)