Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

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

merge of the branch 'modules'

parents f4a70768 8e5ef36a
......@@ -10,6 +10,7 @@ why.conf
*.cmo
*.cmi
*.cmxs
*.annot
\#*\#
# /
......
......@@ -283,8 +283,8 @@ install_no_local::
PGMGENERATED = src/programs/pgm_parser.mli src/programs/pgm_parser.ml \
src/programs/pgm_lexer.ml
PGM_FILES = pgm_ttree pgm_ptree pgm_parser pgm_lexer pgm_effect \
pgm_env pgm_typing pgm_wp pgm_main
PGM_FILES = pgm_ttree pgm_ptree pgm_parser pgm_lexer \
pgm_types pgm_module pgm_wp pgm_env pgm_typing pgm_main
PGMMODULES = $(addprefix src/programs/, $(PGM_FILES))
......@@ -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
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
testl-debug: bin/whyml.byte
ocamlrun -bt bin/whyml.byte --debug-all tests/test-pgm-jcf.mlw
testl-ide: bin/whyide.opt
bin/whyide.opt tests/test-pgm-jcf.mlw
......
whybench.opt
whybench.byte
......@@ -84,7 +84,7 @@ let alt_ergo : Whyconf.config_prover =
exit 0
(* 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 *)
let alt_ergo_driver : Driver.driver = Driver.load_driver env alt_ergo.Whyconf.driver
......
......@@ -29,8 +29,8 @@
;; Note: comment font-lock is guaranteed by suitable syntax entries
;; '("(\\*\\([^*)]\\([^*]\\|\\*[^)]\\)*\\)?\\*)" . font-lock-comment-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 '("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 '("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" "module")) . font-lock-keyword-face)
; `(,(why-regexp-opt '("unit" "bool" "int" "float" "prop" "array")) . font-lock-type-face)
)
"Minimal highlighting for Why mode")
......
bench.annot
whybench.annot
......@@ -51,7 +51,7 @@ let read_tools absf wc map (name,section) =
let timelimit = get_int ~default:(timelimit wc_main) section "timelimit" in
let memlimit = get_int ~default:(memlimit wc_main) section "memlimit" in
(* env *)
let env = Env.create_env (Lexer.retrieve loadpath) in
let env = Lexer.create_env loadpath in
(* transformations *)
let transforms = get_stringl ~default:[] section "transform" in
let lookup acc t = Trans.compose (Trans.lookup_transform t env) acc in
......
......@@ -303,7 +303,7 @@ let () =
in
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 prover = try Mstr.find s (get_provers config) with
| Not_found -> eprintf "Prover %s not found.@." s; exit 1
......
......@@ -46,7 +46,7 @@ let cprovers = Whyconf.get_provers config
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
......
......@@ -22,7 +22,10 @@ open Theory
(** Environment *)
type retrieve_channel = string list -> string * in_channel
type env = {
env_ret_chan : retrieve_channel;
env_retrieve : retrieve_theory;
env_memo : (string list, theory Mnm.t) Hashtbl.t;
env_tag : Hashweak.tag;
......@@ -35,7 +38,8 @@ let create_memo () =
Hashtbl.add ht [] Mnm.empty;
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_memo = create_memo ();
env_tag = (incr c; Hashweak.create_tag !c) }
......@@ -70,6 +74,8 @@ let find_theory env sl s =
else try Mnm.find s (find_library env sl)
with Not_found -> raise (TheoryNotFound (sl, s))
let find_channel env = env.env_ret_chan
let env_tag env = env.env_tag
module Wenv = Hashweak.Make(struct type t = env let tag = env_tag end)
......
......@@ -27,9 +27,13 @@ val env_tag : env -> Hashweak.tag
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
......@@ -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]
@raise TheoryNotFound if theory not present in env [e] *)
val find_channel : env -> string list -> string * in_channel
(** Parsers *)
type read_channel = env -> string -> in_channel -> theory Mnm.t
......
......@@ -111,10 +111,10 @@ let load_config config =
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 *)
let env = Env.create_env (Lexer.retrieve []) in
let env = Lexer.create_env [] in
{ window_height = ide.ide_window_height;
window_width = ide.ide_window_width;
tree_width = ide.ide_tree_width;
......
......@@ -166,7 +166,7 @@ let source_text fname =
let gconfig =
let c = Gconfig.config 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
c.provers <-
Util.Mstr.fold (Gconfig.get_prover_data c.env) provers Util.Mstr.empty;
......
......@@ -444,7 +444,7 @@ let do_input env drv = function
let () =
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
Queue.iter (do_input env drv) opt_queue
with e when not (Debug.test_flag Debug.stack_trace) ->
......
......@@ -50,6 +50,8 @@ and type_var = {
type_var_loc : loc option;
}
let tvsymbol_of_type_var tv = tv.tvsymbol
let rec print_dty fmt = function
| Tyvar { type_val = Some t } ->
print_dty fmt t
......@@ -58,10 +60,9 @@ let rec print_dty fmt = function
| Tyapp (s, []) ->
fprintf fmt "%s" s.ts_name.id_string
| 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) ->
fprintf fmt "(%a) %s"
(print_list comma print_dty) l s.ts_name.id_string
fprintf fmt "%s %a" s.ts_name.id_string (print_list comma print_dty) l
let create_ty_decl_var =
let t = ref 0 in
......
......@@ -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
(** exported for programs *)
val tvsymbol_of_type_var : type_var -> tvsymbol
......@@ -21,7 +21,7 @@ open Theory
(** 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 *)
val parse_list0_decl :
......
......@@ -271,21 +271,32 @@ and string = parse
Loc.set_file file lb;
parse_logic_file env lb
let retrieve lp env sl =
let f = List.fold_left Filename.concat "" sl ^ ".why" in
(* searches file [f] in loadpath [lp] *)
let locate_file lp f =
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
| [file] -> file
| 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
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
Env.create_env ret_chan retrieve
let () = Env.register_format "why" ["why"] read_channel
}
......
......@@ -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 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 *)
let rec qloc = function
......
......@@ -71,6 +71,10 @@ val dfmla : ?localize:bool -> denv -> Ptree.lexpr -> Denv.dfmla
val dpat : denv -> 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 ts_tuple : int -> Ty.tysymbol
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment