Commit bfc3c223 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre

merge of the branch 'modules'

parents f4a70768 8e5ef36a
...@@ -10,6 +10,7 @@ why.conf ...@@ -10,6 +10,7 @@ why.conf
*.cmo *.cmo
*.cmi *.cmi
*.cmxs *.cmxs
*.annot
\#*\# \#*\#
# / # /
......
...@@ -283,8 +283,8 @@ install_no_local:: ...@@ -283,8 +283,8 @@ install_no_local::
PGMGENERATED = src/programs/pgm_parser.mli src/programs/pgm_parser.ml \ PGMGENERATED = src/programs/pgm_parser.mli src/programs/pgm_parser.ml \
src/programs/pgm_lexer.ml src/programs/pgm_lexer.ml
PGM_FILES = pgm_ttree pgm_ptree pgm_parser pgm_lexer pgm_effect \ PGM_FILES = pgm_ttree pgm_ptree pgm_parser pgm_lexer \
pgm_env pgm_typing pgm_wp pgm_main pgm_types pgm_module pgm_wp pgm_env pgm_typing pgm_main
PGMMODULES = $(addprefix src/programs/, $(PGM_FILES)) PGMMODULES = $(addprefix src/programs/, $(PGM_FILES))
...@@ -729,9 +729,12 @@ test: bin/why.byte plugins.byte $(TOOLS) ...@@ -729,9 +729,12 @@ test: bin/why.byte plugins.byte $(TOOLS)
@for i in output_coq/*.v; do printf "coq $$i\\n" && coqc $$i ; done @for i in output_coq/*.v; do printf "coq $$i\\n" && coqc $$i ; done
testl: bin/whyml.byte testl: bin/whyml.byte
ocamlrun -bt bin/whyml.byte --debug-all tests/test-pgm-jcf.mlw ocamlrun -bt bin/whyml.byte tests/test-pgm-jcf.mlw
ocamlrun -bt bin/whyml.byte -P alt-ergo tests/test-pgm-jcf.mlw ocamlrun -bt bin/whyml.byte -P alt-ergo tests/test-pgm-jcf.mlw
testl-debug: bin/whyml.byte
ocamlrun -bt bin/whyml.byte --debug-all tests/test-pgm-jcf.mlw
testl-ide: bin/whyide.opt testl-ide: bin/whyide.opt
bin/whyide.opt tests/test-pgm-jcf.mlw bin/whyide.opt tests/test-pgm-jcf.mlw
......
whybench.opt
whybench.byte
...@@ -84,7 +84,7 @@ let alt_ergo : Whyconf.config_prover = ...@@ -84,7 +84,7 @@ let alt_ergo : Whyconf.config_prover =
exit 0 exit 0
(* builds the environment from the [loadpath] *) (* builds the environment from the [loadpath] *)
let env : Env.env = Env.create_env (Lexer.retrieve (Whyconf.loadpath main)) let env : Env.env = Lexer.create_env (Whyconf.loadpath main)
(* loading the Alt-Ergo driver *) (* loading the Alt-Ergo driver *)
let alt_ergo_driver : Driver.driver = Driver.load_driver env alt_ergo.Whyconf.driver let alt_ergo_driver : Driver.driver = Driver.load_driver env alt_ergo.Whyconf.driver
......
...@@ -29,8 +29,8 @@ ...@@ -29,8 +29,8 @@
;; Note: comment font-lock is guaranteed by suitable syntax entries ;; Note: comment font-lock is guaranteed by suitable syntax entries
;; '("(\\*\\([^*)]\\([^*]\\|\\*[^)]\\)*\\)?\\*)" . font-lock-comment-face) ;; '("(\\*\\([^*)]\\([^*]\\|\\*[^)]\\)*\\)?\\*)" . font-lock-comment-face)
'("{\\([^}]*\\)}" . font-lock-type-face) '("{\\([^}]*\\)}" . font-lock-type-face)
`(,(why-regexp-opt '("use" "clone" "namespace" "import" "export" "inductive" "external" "logic" "parameter" "exception" "axiom" "lemma" "goal" "type")) . font-lock-builtin-face) `(,(why-regexp-opt '("use" "clone" "namespace" "import" "export" "inductive" "external" "logic" "parameter" "exception" "axiom" "lemma" "goal" "type" "mutable" "model")) . font-lock-builtin-face)
`(,(why-regexp-opt '("and" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "invariant" "variant" "for" "to" "downto" "do" "done" "label" "assert" "absurd" "assume" "check" "ghost" "try" "with" "theory" "uses")) . font-lock-keyword-face) `(,(why-regexp-opt '("and" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "invariant" "variant" "for" "to" "downto" "do" "done" "label" "assert" "absurd" "assume" "check" "ghost" "try" "with" "theory" "uses" "module")) . font-lock-keyword-face)
; `(,(why-regexp-opt '("unit" "bool" "int" "float" "prop" "array")) . font-lock-type-face) ; `(,(why-regexp-opt '("unit" "bool" "int" "float" "prop" "array")) . font-lock-type-face)
) )
"Minimal highlighting for Why mode") "Minimal highlighting for Why mode")
......
bench.annot
whybench.annot
...@@ -51,7 +51,7 @@ let read_tools absf wc map (name,section) = ...@@ -51,7 +51,7 @@ let read_tools absf wc map (name,section) =
let timelimit = get_int ~default:(timelimit wc_main) section "timelimit" in let timelimit = get_int ~default:(timelimit wc_main) section "timelimit" in
let memlimit = get_int ~default:(memlimit wc_main) section "memlimit" in let memlimit = get_int ~default:(memlimit wc_main) section "memlimit" in
(* env *) (* env *)
let env = Env.create_env (Lexer.retrieve loadpath) in let env = Lexer.create_env loadpath in
(* transformations *) (* transformations *)
let transforms = get_stringl ~default:[] section "transform" in let transforms = get_stringl ~default:[] section "transform" in
let lookup acc t = Trans.compose (Trans.lookup_transform t env) acc in let lookup acc t = Trans.compose (Trans.lookup_transform t env) acc in
......
...@@ -303,7 +303,7 @@ let () = ...@@ -303,7 +303,7 @@ let () =
in in
opt_task := List.fold_left add_meta !opt_task !opt_metas; opt_task := List.fold_left add_meta !opt_task !opt_metas;
let env = Env.create_env (Lexer.retrieve !opt_loadpath) in let env = Lexer.create_env !opt_loadpath in
let map_prover s = let map_prover s =
let prover = try Mstr.find s (get_provers config) with let prover = try Mstr.find s (get_provers config) with
| Not_found -> eprintf "Prover %s not found.@." s; exit 1 | Not_found -> eprintf "Prover %s not found.@." s; exit 1
......
...@@ -46,7 +46,7 @@ let cprovers = Whyconf.get_provers config ...@@ -46,7 +46,7 @@ let cprovers = Whyconf.get_provers config
let timelimit = timelimit main let timelimit = timelimit main
let env = Env.create_env (Lexer.retrieve (loadpath main)) let env = Lexer.create_env (loadpath main)
let provers = Hashtbl.create 17 let provers = Hashtbl.create 17
......
...@@ -22,7 +22,10 @@ open Theory ...@@ -22,7 +22,10 @@ open Theory
(** Environment *) (** Environment *)
type retrieve_channel = string list -> string * in_channel
type env = { type env = {
env_ret_chan : retrieve_channel;
env_retrieve : retrieve_theory; env_retrieve : retrieve_theory;
env_memo : (string list, theory Mnm.t) Hashtbl.t; env_memo : (string list, theory Mnm.t) Hashtbl.t;
env_tag : Hashweak.tag; env_tag : Hashweak.tag;
...@@ -35,7 +38,8 @@ let create_memo () = ...@@ -35,7 +38,8 @@ let create_memo () =
Hashtbl.add ht [] Mnm.empty; Hashtbl.add ht [] Mnm.empty;
ht ht
let create_env = let c = ref (-1) in fun retrieve -> { let create_env = let c = ref (-1) in fun ret_chan retrieve -> {
env_ret_chan = ret_chan;
env_retrieve = retrieve; env_retrieve = retrieve;
env_memo = create_memo (); env_memo = create_memo ();
env_tag = (incr c; Hashweak.create_tag !c) } env_tag = (incr c; Hashweak.create_tag !c) }
...@@ -70,6 +74,8 @@ let find_theory env sl s = ...@@ -70,6 +74,8 @@ let find_theory env sl s =
else try Mnm.find s (find_library env sl) else try Mnm.find s (find_library env sl)
with Not_found -> raise (TheoryNotFound (sl, s)) with Not_found -> raise (TheoryNotFound (sl, s))
let find_channel env = env.env_ret_chan
let env_tag env = env.env_tag let env_tag env = env.env_tag
module Wenv = Hashweak.Make(struct type t = env let tag = env_tag end) module Wenv = Hashweak.Make(struct type t = env let tag = env_tag end)
......
...@@ -27,9 +27,13 @@ val env_tag : env -> Hashweak.tag ...@@ -27,9 +27,13 @@ val env_tag : env -> Hashweak.tag
module Wenv : Hashweak.S with type key = env module Wenv : Hashweak.S with type key = env
type retrieve_theory = env -> string list -> theory Mnm.t type retrieve_channel = string list -> string * in_channel
(** retrieves a channel from a given path; a filename is also returned,
for printing purposes only *)
val create_env : retrieve_theory -> env type retrieve_theory = env -> string list -> theory Mnm.t
val create_env : retrieve_channel -> retrieve_theory -> env
exception TheoryNotFound of string list * string exception TheoryNotFound of string list * string
...@@ -37,6 +41,8 @@ val find_theory : env -> string list -> string -> theory ...@@ -37,6 +41,8 @@ val find_theory : env -> string list -> string -> theory
(** [find_theory e p n] finds the theory named [p.n] in environment [e] (** [find_theory e p n] finds the theory named [p.n] in environment [e]
@raise TheoryNotFound if theory not present in env [e] *) @raise TheoryNotFound if theory not present in env [e] *)
val find_channel : env -> string list -> string * in_channel
(** Parsers *) (** Parsers *)
type read_channel = env -> string -> in_channel -> theory Mnm.t type read_channel = env -> string -> in_channel -> theory Mnm.t
......
...@@ -111,10 +111,10 @@ let load_config config = ...@@ -111,10 +111,10 @@ let load_config config =
let provers = get_provers config in let provers = get_provers config in
*) *)
(* (*
let env = Env.create_env (Lexer.retrieve main.loadpath) in let env = Lexer.create_env main.loadpath in
*) *)
(* temporary sets env to empty *) (* temporary sets env to empty *)
let env = Env.create_env (Lexer.retrieve []) in let env = Lexer.create_env [] in
{ window_height = ide.ide_window_height; { window_height = ide.ide_window_height;
window_width = ide.ide_window_width; window_width = ide.ide_window_width;
tree_width = ide.ide_tree_width; tree_width = ide.ide_tree_width;
......
...@@ -166,7 +166,7 @@ let source_text fname = ...@@ -166,7 +166,7 @@ let source_text fname =
let gconfig = let gconfig =
let c = Gconfig.config in let c = Gconfig.config in
let loadpath = (Whyconf.loadpath (get_main ())) @ List.rev !includes in let loadpath = (Whyconf.loadpath (get_main ())) @ List.rev !includes in
c.env <- Env.create_env (Lexer.retrieve loadpath); c.env <- Lexer.create_env loadpath;
let provers = Whyconf.get_provers c.Gconfig.config in let provers = Whyconf.get_provers c.Gconfig.config in
c.provers <- c.provers <-
Util.Mstr.fold (Gconfig.get_prover_data c.env) provers Util.Mstr.empty; Util.Mstr.fold (Gconfig.get_prover_data c.env) provers Util.Mstr.empty;
......
...@@ -444,7 +444,7 @@ let do_input env drv = function ...@@ -444,7 +444,7 @@ let do_input env drv = function
let () = let () =
try try
let env = Env.create_env (Lexer.retrieve !opt_loadpath) in let env = Lexer.create_env !opt_loadpath in
let drv = Util.option_map (load_driver env) !opt_driver in let drv = Util.option_map (load_driver env) !opt_driver in
Queue.iter (do_input env drv) opt_queue Queue.iter (do_input env drv) opt_queue
with e when not (Debug.test_flag Debug.stack_trace) -> with e when not (Debug.test_flag Debug.stack_trace) ->
......
...@@ -50,6 +50,8 @@ and type_var = { ...@@ -50,6 +50,8 @@ and type_var = {
type_var_loc : loc option; type_var_loc : loc option;
} }
let tvsymbol_of_type_var tv = tv.tvsymbol
let rec print_dty fmt = function let rec print_dty fmt = function
| Tyvar { type_val = Some t } -> | Tyvar { type_val = Some t } ->
print_dty fmt t print_dty fmt t
...@@ -58,10 +60,9 @@ let rec print_dty fmt = function ...@@ -58,10 +60,9 @@ let rec print_dty fmt = function
| Tyapp (s, []) -> | Tyapp (s, []) ->
fprintf fmt "%s" s.ts_name.id_string fprintf fmt "%s" s.ts_name.id_string
| Tyapp (s, [t]) -> | Tyapp (s, [t]) ->
fprintf fmt "%a %s" print_dty t s.ts_name.id_string fprintf fmt "%s %a" s.ts_name.id_string print_dty t
| Tyapp (s, l) -> | Tyapp (s, l) ->
fprintf fmt "(%a) %s" fprintf fmt "%s %a" s.ts_name.id_string (print_list comma print_dty) l
(print_list comma print_dty) l s.ts_name.id_string
let create_ty_decl_var = let create_ty_decl_var =
let t = ref 0 in let t = ref 0 in
......
...@@ -95,3 +95,6 @@ val specialize_term : loc:Ptree.loc -> type_var Htv.t -> term -> dterm ...@@ -95,3 +95,6 @@ val specialize_term : loc:Ptree.loc -> type_var Htv.t -> term -> dterm
val specialize_fmla : loc:Ptree.loc -> type_var Htv.t -> fmla -> dfmla val specialize_fmla : loc:Ptree.loc -> type_var Htv.t -> fmla -> dfmla
(** exported for programs *)
val tvsymbol_of_type_var : type_var -> tvsymbol
...@@ -21,7 +21,7 @@ open Theory ...@@ -21,7 +21,7 @@ open Theory
(** parsing entry points *) (** parsing entry points *)
val retrieve : string list -> Env.retrieve_theory val create_env : string list -> Env.env
(** creates a new typing environment for a given loadpath *) (** creates a new typing environment for a given loadpath *)
val parse_list0_decl : val parse_list0_decl :
......
...@@ -271,21 +271,32 @@ and string = parse ...@@ -271,21 +271,32 @@ and string = parse
Loc.set_file file lb; Loc.set_file file lb;
parse_logic_file env lb parse_logic_file env lb
let retrieve lp env sl = (* searches file [f] in loadpath [lp] *)
let f = List.fold_left Filename.concat "" sl ^ ".why" in let locate_file lp f =
let fl = List.map (fun dir -> Filename.concat dir f) lp in let fl = List.map (fun dir -> Filename.concat dir f) lp in
let file = match List.filter Sys.file_exists fl with match List.filter Sys.file_exists fl with
| [] -> raise Not_found | [] -> raise Not_found
| [file] -> file | [file] -> file
| file1 :: file2 :: _ -> raise (AmbiguousPath (file1, file2)) | file1 :: file2 :: _ -> raise (AmbiguousPath (file1, file2))
let create_env lp =
let ret_chan sl =
let f = List.fold_left Filename.concat "" sl in
let file = locate_file lp f in
file, open_in file
in
let retrieve env sl =
let f = List.fold_left Filename.concat "" sl ^ ".why" in
let file = locate_file lp f in
let c = open_in file in
try
let tl = read_channel env file c in
close_in c;
tl
with
| e -> close_in c; raise e
in in
let c = open_in file in Env.create_env ret_chan retrieve
try
let tl = read_channel env file c in
close_in c;
tl
with
| e -> close_in c; raise e
let () = Env.register_format "why" ["why"] read_channel let () = Env.register_format "why" ["why"] read_channel
} }
......
...@@ -146,6 +146,9 @@ let mem_var x denv = Mstr.mem x denv.dvars ...@@ -146,6 +146,9 @@ let mem_var x denv = Mstr.mem x denv.dvars
let find_var x denv = Mstr.find x denv.dvars let find_var x denv = Mstr.find x denv.dvars
let add_var x ty denv = { denv with dvars = Mstr.add x ty denv.dvars } let add_var x ty denv = { denv with dvars = Mstr.add x ty denv.dvars }
let print_denv fmt denv =
Mstr.iter (fun x ty -> fprintf fmt "%s:%a,@ " x print_dty ty) denv.dvars
(* parsed types -> intermediate types *) (* parsed types -> intermediate types *)
let rec qloc = function let rec qloc = function
......
...@@ -71,6 +71,10 @@ val dfmla : ?localize:bool -> denv -> Ptree.lexpr -> Denv.dfmla ...@@ -71,6 +71,10 @@ val dfmla : ?localize:bool -> denv -> Ptree.lexpr -> Denv.dfmla
val dpat : denv -> Ptree.pattern -> denv * Denv.dpattern val dpat : denv -> Ptree.pattern -> denv * Denv.dpattern
val dpat_list : denv -> Denv.dty -> Ptree.pattern -> denv * Denv.dpattern val dpat_list : denv -> Denv.dty -> Ptree.pattern -> denv * Denv.dpattern
val print_denv : Format.formatter -> denv -> unit
val split_qualid : Ptree.qualid -> string list * string
val string_list_of_qualid : string list -> Ptree.qualid -> string list
val qloc : Ptree.qualid -> Loc.position val qloc : Ptree.qualid -> Loc.position
val ts_tuple : int -> Ty.tysymbol val ts_tuple : int -> Ty.tysymbol
......
o refs -> mutable types
o loadpath: how to retrieve program files? (cannot use "env")
o what about pervasives old, at, label, exn, unit = (), lt_nat
...@@ -18,383 +18,41 @@ ...@@ -18,383 +18,41 @@
(**************************************************************************) (**************************************************************************)
open Why open Why
open Util open Pgm_module
open Ident
open Theory
open Term
open Ty
module E = Pgm_effect
(* types *) type t = {
env : Env.env;
type effect = E.t retrieve : retrieve_module;
type reference = Pgm_effect.reference memo : (string list, Pgm_module.t Mnm.t) Hashtbl.t;
type pre = Term.fmla
type post_fmla = Term.vsymbol (* result *) * Term.fmla
type exn_post_fmla = Term.vsymbol (* result *) option * Term.fmla
type post = post_fmla * (Term.lsymbol * exn_post_fmla) list
type type_v =
| Tpure of Ty.ty
| Tarrow of binder list * type_c
and type_c =
{ c_result_type : type_v;
c_effect : effect;
c_pre : pre;
c_post : post; }
and binder = Term.vsymbol * type_v
(* environments *)
type env = {
uc : theory_uc;
(***
globals : type_v Mls.t;
locals : type_v Mvs.t;
***)
globals : (lsymbol * type_v) Mstr.t;
exceptions : lsymbol Mstr.t;
ts_arrow: tysymbol;
ts_bool : tysymbol;
ts_label: tysymbol;
ts_ref: tysymbol;
ts_exn: tysymbol;
ts_unit : tysymbol;
ls_at : lsymbol;
ls_bang : lsymbol;
ls_old : lsymbol;
ls_True : lsymbol;
ls_False: lsymbol;
ls_andb : lsymbol;
ls_orb : lsymbol;
ls_notb : lsymbol;
ls_unit : lsymbol;
ls_lt : lsymbol;
ls_gt : lsymbol;
ls_le : lsymbol;
ls_ge : lsymbol;
ls_add : lsymbol;
} }
and retrieve_module = t -> string -> in_channel -> Pgm_module.t Mnm.t
(* prelude *) let get_env penv = penv.env
let find_ts uc = ns_find_ts (get_namespace uc)
let find_ls uc = ns_find_ls (get_namespace uc)
(* predefined lsymbols are memoized wrt the lsymbol for type "ref" *)
let memo_ls f =
let h = Hts.create 17 in
fun uc ->
let ts_ref = find_ts uc ["ref"] in
try Hts.find h ts_ref
with Not_found -> let s = f uc ts_ref in Hts.add h ts_ref s; s
(* logic ref ('a) : 'a ref *)
let ls_ref = memo_ls
(fun _uc ts_ref ->
let a = ty_var (create_tvsymbol (id_fresh "a")) in
create_lsymbol (id_fresh "ref") [a] (Some (ty_app ts_ref [a])))
(* logic (:=)('a ref, 'a) : unit *)
let ls_assign = memo_ls
(fun uc ts_ref ->
let ty_unit = ty_app (find_ts uc ["unit"]) [] in
let a = ty_var (create_tvsymbol (id_fresh "a")) in
create_lsymbol (id_fresh "infix :=") [ty_app ts_ref [a]; a] (Some ty_unit))
let ls_Exit = memo_ls
(fun uc _ ->
let ty_exn = ty_app (find_ts uc ["exn"]) [] in
create_lsymbol (id_fresh "%Exit") [] (Some ty_exn))
let v_result ty = create_vsymbol (id_fresh "result") ty
let exn_v_result ls = match ls.ls_args with let create env retrieve = {
| [] -> None env = env;
| [ty] -> Some (v_result ty) retrieve = retrieve;
| _ -> assert false memo = Hashtbl.create 17;
let add_type_v_ref uc m =
let ts_ref = find_ts uc ["ref"] in
let a = ty_var (create_tvsymbol (id_fresh "a")) in
let x = create_vsymbol (id_fresh "x") a in
let ty = ty_app ts_ref [a] in
let result = v_result ty in
let q = f_equ (t_app (find_ls uc ["prefix !"]) [t_var result] a) (t_var x) in
let c = { c_result_type = Tpure ty;
c_effect = Pgm_effect.empty;
c_pre = f_true;
c_post = (result, q), []; } in
let v = Tarrow ([x, Tpure a], c) in
Mstr.add "ref" (ls_ref uc, v) m
let add_type_v_assign uc m =
let ts_ref = find_ts uc ["ref"] in
let a = ty_var (create_tvsymbol (id_fresh "a")) in
let a_ref = ty_app ts_ref [a] in
let x = create_vsymbol (id_fresh "x") a_ref in
let y = create_vsymbol (id_fresh "y") a in
let ty = ty_app (find_ts uc ["unit"]) [] in
let result = v_result ty in
let q = f_equ (t_app (find_ls uc ["prefix !"]) [t_var x] a) (t_var y) in
let c = { c_result_type = Tpure ty;
c_effect = E.add_write (E.Rlocal x) E.empty;
c_pre = f_true;
c_post = (result, q), []; } in
let v = Tarrow ([x, Tpure a_ref; y, Tpure a], c) in
Mstr.add "infix :=" (ls_assign uc, v) m
let empty_env uc = {
uc = uc;
globals = add_type_v_ref uc (add_type_v_assign uc Mstr.empty);
exceptions = Mstr.add "%Exit" (ls_Exit uc) Mstr.empty;
(* types *)
ts_arrow = find_ts uc ["arrow"];
ts_bool = find_ts uc ["bool"];
ts_label = find_ts uc ["label"];
ts_ref = find_ts uc ["ref"];
ts_exn = find_ts uc ["exn"];
ts_unit = find_ts uc ["tuple0"];
(* functions *)
ls_at = find_ls uc ["at"];
ls_bang = find_ls uc ["prefix !"];
ls_old = find_ls uc ["old"];
ls_True = find_ls uc ["True"];
ls_False = find_ls uc ["False"];
ls_andb = find_ls uc ["andb"];
ls_orb = find_ls uc ["orb"];
ls_notb = find_ls uc ["notb"];
ls_unit = find_ls uc ["Tuple0"];
ls_lt = find_ls uc ["infix <"];
ls_gt = find_ls uc ["infix >"];
ls_le = find_ls uc ["infix <="];
ls_ge = find_ls uc ["infix >="];
ls_add = find_ls uc ["infix +"];
} }
let make_arrow_type env tyl ty = exception ModuleNotFound of string list * string
let arrow ty1 ty2 = Ty.ty_app env.ts_arrow [ty1; ty2] in
List.fold_right arrow tyl ty let rec add_suffix = function
| [] -> assert false
let rec uncurry_type = function | [f] -> [f ^ ".mlw"]
| Tpure ty -> | p :: f -> p :: add_suffix f
[], ty
| Tarrow (bl, c) -> let find_library penv sl =
let tyl1 = List.map (fun (v,_) -> v.vs_ty) bl in try Hashtbl.find penv.memo sl
let tyl2, ty = uncurry_type c.c_result_type in with Not_found ->
tyl1 @ tyl2, ty (* TODO: improve? *) Hashtbl.add penv.memo sl Mnm.empty;
let file, c = Env.find_channel penv.env (add_suffix sl) in
let purify env v = let m = penv.retrieve penv file c in
let tyl, ty = uncurry_type v in close_in c;
make_arrow_type env tyl ty Hashtbl.replace penv.memo sl m;
m
(* parsing LOGIC strings using functions from src/parser/
requires proper relocation *) let find_module penv sl s =
try Mnm.find s (find_library penv sl)
let reloc loc lb = with Not_found -> raise (ModuleNotFound (sl, s))
lb.Lexing.lex_curr_p <- loc;
lb.Lexing.lex_abs_pos <- loc.Lexing.pos_cnum + 1
let parse_string f loc s =
let lb = Lexing.from_string s in
reloc loc lb;
f lb
let logic_lexpr ((pos, _), s) =
parse_string Lexer.parse_lexpr pos s
let logic_decls ((loc, _), s) e env =
let parse = Lexer.parse_list0_decl e Mnm.empty env.uc in
{ env with uc = parse_string parse loc s }
(* addition *)
let add_global id tyv env =
let tyl, ty = uncurry_type tyv in
let s = create_lsymbol id tyl (Some ty) in
s, { env with globals = Mstr.add s.ls_name.id_string (s, tyv) env.globals }
let add_decl d env =
{ env with uc = Typing.with_tuples add_decl env.uc d }
let add_exception id ty env =
let tyl = match ty with None -> [] | Some ty -> [ty] in
let s = create_lsymbol id tyl (Some (ty_app env.ts_exn [])) in
s, { env with exceptions = Mstr.add s.ls_name.id_string s env.exceptions }
(* misc. functions *)
let post_map f ((v, q), ql) =
(v, f q), List.map (fun (e,(v,q)) -> e, (v, f q)) ql