alt-ergo-1.30/0000755000175000001440000000000013217000160011501 5ustar rtusersalt-ergo-1.30/src/0000755000175000001440000000000013014515065012302 5ustar rtusersalt-ergo-1.30/src/main/0000755000175000001440000000000013014515065013226 5ustar rtusersalt-ergo-1.30/src/main/main_text.mli0000644000175000001440000000315413014515065015724 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (* empty interface *) alt-ergo-1.30/src/main/main_gui.mli0000644000175000001440000000315413014515065015524 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (* empty interface *) alt-ergo-1.30/src/main/frontend.ml0000644000175000001440000002160113014515065015377 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Typed open Commands open Lexing open Format open Options module type S = sig type sat_env type output = Unsat of Explanation.t | Inconsistent | Sat of sat_env | Unknown of sat_env val process_decl: (Commands.sat_tdecl -> output -> int64 -> unit) -> sat_env * bool * Explanation.t -> Commands.sat_tdecl -> sat_env * bool * Explanation.t val parse_and_typecheck: string -> Lexing.lexbuf option -> ((int tdecl, int) annoted * Why_typing.env) list list val print_status : Commands.sat_tdecl -> output -> int64 -> unit end module Make(SAT : Sat_solvers.S) : S with type sat_env = SAT.t = struct type sat_env = SAT.t type output = Unsat of Explanation.t | Inconsistent | Sat of sat_env | Unknown of sat_env let check_produced_proof dep = if verbose () then fprintf fmt "checking the proof:\n-------------------\n%a@." Explanation.print_proof dep; try let pb = Formula.Set.elements (Explanation.formulas_of dep) in let env = List.fold_left (fun env f -> SAT.assume env {Formula.f=f; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=false; gf=false; from_terms = [] } ) (SAT.empty ()) pb in ignore (SAT.unsat env {Formula.f=Formula.vrai; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=false; gf=false; from_terms = [] }); fprintf fmt "Checking produced proof failed!@."; fprintf fmt "this may be due to a bug.@."; exit 1 with | SAT.Unsat _ -> () | (SAT.Sat _ | SAT.I_dont_know _) as e -> raise e let do_save_used_context env dep = if not (Options.js_mode ()) then let used, unused = SAT.retrieve_used_context env dep in let f = Options.get_used_context_file () in let cout = open_out f in List.iter (fun f -> match Formula.view f with | Formula.Lemma {Formula.name=name} -> output_string cout (sprintf "%s\n" name) | _ -> assert false ) used; close_out cout let process_decl print_status (env, consistent, dep) d = try match d.st_decl with | Assume(f, mf) -> if consistent then SAT.assume env {Formula.f=f; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=mf; gf=false; from_terms = [] }, consistent, dep else env, consistent, dep | PredDef (f, name) -> SAT.pred_def env f name d.st_loc, consistent, dep | RwtDef r -> assert false | Query(n, f, lits, sort) -> let dep = if consistent then let dep' = SAT.unsat env {Formula.f=f; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=(sort != Check); gf=true; from_terms = [] } in Explanation.union dep' dep else dep in if debug_proof () then check_produced_proof dep; if save_used_context () then do_save_used_context env dep; print_status d (Unsat dep) (SAT.get_steps ()); env, consistent, dep with | SAT.Sat t -> print_status d (Sat t) (SAT.get_steps ()); if model () then SAT.print_model ~header:true std_formatter t; env , consistent, dep | SAT.Unsat dep' -> let dep = Explanation.union dep dep' in if debug_proof () then check_produced_proof dep; print_status d Inconsistent (SAT.get_steps ()); env , false, dep | SAT.I_dont_know t -> print_status d (Unknown t) (SAT.get_steps ()); if model () then SAT.print_model ~header:true std_formatter t; env , consistent, dep exception Parse_only (* pre-condition: f is of the form f'.zip *) let extract_zip_file f = let cin = MyZip.open_in f in try match MyZip.entries cin with | [e] when not (MyZip.is_directory e) -> if verbose () then eprintf "I'll read the content of '%s' in the given zip@." (MyZip.filename e); let content = MyZip.read_entry cin e in MyZip.close_in cin; content | _ -> MyZip.close_in cin; raise (Arg.Bad (sprintf "%s '%s' %s@?" "The zipped file" f "should contain exactly one file.")) with e -> MyZip.close_in cin; raise e let close_and_exit opened_cin cin retcode = if opened_cin then close_in cin; exit retcode (* lb_opt is set in to Some lb in JavaScript mode *) let parse_and_typecheck file lb_opt = let cin, lb, opened_cin = match lb_opt, Filename.check_suffix file ".zip" with | None, false -> if Pervasives.(<>) file "" then let cin = open_in file in cin, from_channel cin, true else stdin, from_channel stdin, false | None, true -> let file_content = extract_zip_file file in stdin, from_string file_content, false | Some lb, false -> stdin, lb, false | Some lb, true -> eprintf "Error: Zip files are not supported in JS mode !@."; exit 1 in try let a = Why_parser.file Why_lexer.token lb in Parsing.clear_parser (); if parse_only () then close_and_exit opened_cin cin 0; let ltd, typ_env = Why_typing.file false Why_typing.empty_env a in let d = Why_typing.split_goals ltd in if type_only () then close_and_exit opened_cin cin 0; if opened_cin then close_in cin; d with | Why_lexer.Lexical_error s -> Loc.report err_formatter (lexeme_start_p lb, lexeme_end_p lb); eprintf "lexical error: %s\n@." s; close_and_exit opened_cin cin 1 | Parsing.Parse_error -> let loc = (lexeme_start_p lb, lexeme_end_p lb) in Loc.report err_formatter loc; eprintf "syntax error\n@."; close_and_exit opened_cin cin 1 | Errors.Error(e,l) -> Loc.report err_formatter l; eprintf "typing error: %a\n@." Errors.report e; close_and_exit opened_cin cin 1 let print_status d status steps = let time = Time.value() in let loc = d.st_loc in match status with | Unsat dep -> if js_mode () then printf "# [answer] Valid (%2.4f seconds) (%Ld steps)@." time steps else begin printf "%aValid (%2.4f) (%Ld steps)@." Loc.report loc time steps; if proof () && not (debug_proof ()) && not (save_used_context ()) then printf "Proof:\n%a@." Explanation.print_proof dep end | Inconsistent -> if js_mode () then printf "# [message] Inconsistent assumption \n@." else eprintf "%aInconsistent assumption@." Loc.report loc; | Unknown t | Sat t -> if js_mode () then printf "# [answer] unknown (%2.4f seconds) (%Ld steps)@." time steps else printf "%aI don't know (%2.4f) (%Ld steps)@." Loc.report loc time steps end alt-ergo-1.30/src/main/main_gui.ml0000644000175000001440000013114113014515065015351 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Typed open Commands open Why_annoted open Why_connected open Lexing open Format open Options module SAT = (val (Sat_solvers.get_current ()) : Sat_solvers.S) module FE = Frontend.Make(SAT) (* type search_bar = { *) (* sbar: GButton.toolbar; *) (* sbox: GPack.box; *) (* sentry: GEdit.entry; *) (* button_forw: GButton.button; *) (* button_back: GButton.button; *) (* found_all_tag: GText.tag; *) (* found_tag: GText.tag; *) (* } *) (* type page_toolbar = { *) (* pbox: GPack.box; *) (* pbar: GButton.toolbar; *) (* button_context: GButton.button; *) (* button_run: GButton.button; *) (* button_stop: GButton.button; *) (* result_box: GPack.box; *) (* result_image: GMisc.image; *) (* result_label: GMisc.label; *) (* button_clean: GButton.button; *) (* search_bar: search_bar; *) (* } *) (* type page = { *) (* tab_label: GMisc.label; *) (* page_nb: int; *) (* event_box: GBin.event_box; *) (* toolbar: page_toolbar; *) (* statusbar: GMisc.statusbar; *) (* st_ctx : GMisc.statusbar_context; *) (* main_view: GSourceView2.source_view; *) (* main_buffer: GSourceView2.source_buffer; *) (* inst_view: GSourceView2.source_view; *) (* inst_buffer: GSourceView2.source_buffer; *) (* error_model: error_model; *) (* inst_model: inst_model; *) (* timers_model: timers_model; *) (* mutable ast : (atyped_decl annoted * Why_typing.env) list; *) (* dep : (atyped_decl annoted list * atyped_decl annoted list) MDep.t; *) (* thread: Thread.t option; *) (* mutable ctrl_toggled : bool; *) (* mutable last_tag : GText.tag; *) (* mutable search_tags : GText.tag list; *) (* mutable proof_tags : GText.tag list; *) (* mutable proof_toptags : GText.tag list; *) (* mutable start_select : int option; *) (* mutable stop_select : int option; *) (* actions : Gui_session.action Stack.t; *) (* saved_actions : Gui_session.action Stack.t; *) (* resulting_ids : (string * int) list; *) (* } *) (* type gui = { *) (* source_language: GSourceView2.source_language option; *) (* scheme: GSourceView2.source_style_scheme option; *) (* note_search: (int, GEdit.entry * (unit -> unit)) Hashtbl.t; *) (* w: GWindow.window; *) (* menubar: GMenu.menu_shell; *) (* notebook: GPack.notebook; *) (* mutable pages: page list; *) (* } *) let inf = Glib.Utf8.from_unichar 8734 let window_width = 950 let window_height = 700 (* GTK *) let () = try let _ = GMain.init () in () with Gtk.Error s -> eprintf "%s@." s let () = Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> print_endline "User wants me to stop."; exit 1)) let save_session envs = let session_cout = open_out_gen [Open_creat; Open_wronly; Open_binary] 0o640 (get_session_file()) in List.iter (fun env -> output_value session_cout env.resulting_ids; output_value session_cout env.actions) envs; close_out session_cout let save_dialog cancel envs () = if List.exists (fun env -> Pervasives.(<>) env.actions env.saved_actions) envs then if List.exists (fun env -> not (Gui_session.safe_session env.actions)) envs then GToolbox.message_box ~title:"Unsafe session" ~icon:(GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG ()) ~ok:"OK" "Your current session is unsafe: satifiability is not preserved.\nPlease ensure you haven't performed any incorrect prunings before saving." else if GToolbox.question_box ~title:"Save session" ~buttons:[cancel; "Save"] ~default:2 ~icon:(GMisc.image ~stock:`SAVE ~icon_size:`DIALOG ()) "Would you like to save the current session ?" = 2 then save_session envs let quit envs () = save_dialog "Quit" envs (); GMain.quit () let show_about () = let v = "Alt-Ergo" in let aw = GWindow.about_dialog ~name:v ~position:`CENTER ~authors:["Sylvain Conchon"; "Évelyne Contejean"; "Francois Bobot"; "Mohamed Iguernelala"; "Stephane Lescuyer"; "Alain Mebsout"] ~copyright:"CNRS - INRIA - Université Paris Sud (2006-2013)\nOCamlPro (2013-2015)" ~license:"CeCILL-C" ~version:Version.version ~website:"http://alt-ergo.lri.fr\nhttp://alt-ergo.ocamlpro.com" ~title:v () in ignore (aw#connect#response ~callback:(fun _ -> aw#destroy ())); ignore (aw#connect#close ~callback:(aw#destroy)); aw#show () let pop_error ?(error=false) ~message () = let pop_w = GWindow.dialog ~title:(if error then "Error" else "Warning") ~allow_grow:true ~position:`CENTER ~width:400 () in let bbox = GPack.button_box `HORIZONTAL ~border_width:5 ~layout:`END ~child_height:20 ~child_width:85 ~spacing:10 ~packing:pop_w#action_area#add () in let button_ok = GButton.button ~packing:bbox#add () in let phbox = GPack.hbox ~packing:button_ok#add () in ignore(GMisc.image ~stock:`OK ~packing:phbox#add ()); ignore(GMisc.label ~text:"OK" ~packing:phbox#add ()); let hbox = GPack.hbox ~border_width:5 ~packing:pop_w#vbox#pack () in ignore(GMisc.image ~stock:(if error then `DIALOG_ERROR else `DIALOG_WARNING) ~icon_size:`DIALOG ~packing:hbox#pack ()); ignore(GMisc.label ~text:message ~xalign:0. ~xpad:10 ~packing:hbox#add ()); ignore(button_ok#connect#clicked ~callback: pop_w#destroy); pop_w#show () let pop_model sat_env () = let pop_w = GWindow.dialog ~title:"Model" ~allow_grow:true ~destroy_with_parent:true ~position:`CENTER ~width:400 ~height:300 () in let sw1 = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:pop_w#vbox#add () in let buf1 = GSourceView2.source_buffer () in let tv1 = GSourceView2.source_view ~source_buffer:buf1 ~packing:(sw1#add) ~wrap_mode:`CHAR() in let _ = tv1#misc#modify_font monospace_font in let _ = tv1#set_editable false in fprintf str_formatter "%a" (SAT.print_model ~header:false) sat_env; let model_text = (flush_str_formatter()) in buf1#set_text model_text; pop_w#show () let compare_rows icol_number (model:#GTree.model) row1 row2 = let t1 = model#get ~row:row1 ~column:icol_number in let t2 = model#get ~row:row2 ~column:icol_number in Pervasives.compare t1 t2 let empty_inst_model () = let icols = new GTree.column_list in let icol_icon = icols#add GtkStock.conv in let icol_desc = icols#add Gobject.Data.string in let icol_number = icols#add Gobject.Data.int in let icol_limit = icols#add Gobject.Data.string in let icol_tag = icols#add Gobject.Data.int in let istore = GTree.list_store icols in istore#set_sort_func icol_number.GTree.index (compare_rows icol_number); istore#set_sort_func icol_desc.GTree.index (compare_rows icol_desc); istore#set_sort_column_id icol_number.GTree.index `DESCENDING; { h = Hashtbl.create 17; max = 0; icols = icols; icol_icon = icol_icon; icol_desc = icol_desc; icol_number = icol_number; icol_limit = icol_limit; icol_tag = icol_tag; istore = istore; } let empty_timers_model (table:GPack.table) = let t = { timers = Timers.empty (); label_sat = GMisc.label ~text:"SAT" ~justify:`LEFT ~xalign:0. ~packing:(table#attach ~left:0 ~top:0) (); label_match = GMisc.label ~text:"Matching" ~justify:`LEFT ~xalign:0. ~packing:(table#attach ~left:0 ~top:1) (); label_cc = GMisc.label ~text:"CC(X)" ~justify:`LEFT ~xalign:0. ~packing:(table#attach ~left:0 ~top:2) (); label_arith = GMisc.label ~text:"Arith" ~justify:`LEFT ~xalign:0. ~packing:(table#attach ~left:0 ~top:3) (); label_arrays = GMisc.label ~text:"Arrays" ~justify:`LEFT~xalign:0. ~packing:(table#attach ~left:0 ~top:4) (); label_sum = GMisc.label ~text:"Sum" ~justify:`LEFT ~xalign:0. ~packing:(table#attach ~left:0 ~top:5) (); label_records = GMisc.label ~text:"Records" ~justify:`LEFT ~xalign:0. ~packing:(table#attach ~left:0 ~top:6) (); label_ac = GMisc.label ~text:"AC(X)" ~justify:`LEFT ~xalign:0. ~packing:(table#attach ~left:0 ~top:7) (); tl_sat = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:0) (); tl_match = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:1) (); tl_cc = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:2) (); tl_arith = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:3) (); tl_arrays = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:4) (); tl_sum = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:5) (); tl_records = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:6) (); tl_ac = GMisc.label ~text:"0.000 s" ~justify:`RIGHT ~packing:(table#attach ~left:1 ~top:7) (); pr_sat = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:0 ~expand:`X ~shrink:`BOTH) (); pr_match = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:1 ~expand:`X ~shrink:`BOTH) (); pr_cc = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:2 ~expand:`X ~shrink:`BOTH) (); pr_arith = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:3 ~expand:`X ~shrink:`BOTH) (); pr_arrays = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:4 ~expand:`X ~shrink:`BOTH) (); pr_sum = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:5 ~expand:`X ~shrink:`BOTH) (); pr_records = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:6 ~expand:`X ~shrink:`BOTH) (); pr_ac = GRange.progress_bar ~packing:(table#attach ~left:2 ~top:7 ~expand:`X ~shrink:`BOTH) (); } in t.pr_sat#set_text " 0 %"; t.pr_match#set_text " 0 %"; t.pr_cc#set_text " 0 %"; t.pr_arith#set_text " 0 %"; t.pr_arrays#set_text " 0 %"; t.pr_sum#set_text " 0 %"; t.pr_records#set_text " 0 %"; t.pr_ac#set_text " 0 %"; t let pump () = while Glib.Main.iteration false do () done let refresh_timers t () = let tsat = Timers.get_sum t.timers Timers.M_Sat in let tmatch = Timers.get_sum t.timers Timers.M_Match in let tcc = Timers.get_sum t.timers Timers.M_CC in let tarith = Timers.get_sum t.timers Timers.M_Arith in let tarrays = Timers.get_sum t.timers Timers.M_Arrays in let tsum = Timers.get_sum t.timers Timers.M_Sum in let trecords = Timers.get_sum t.timers Timers.M_Records in let tac = Timers.get_sum t.timers Timers.M_AC in let total = tsat +. tmatch +. tcc +. tarith +. tarrays +. tsum +. trecords +. tac in let total = if Pervasives.(=) total 0. then 1. else total in t.tl_sat#set_text (sprintf "%3.2f s" tsat); t.tl_match#set_text (sprintf "%3.2f s" tmatch); t.tl_cc#set_text (sprintf "%3.2f s" tcc); t.tl_arith#set_text (sprintf "%3.2f s" tarith); t.tl_arrays#set_text (sprintf "%3.2f s" tarrays); t.tl_sum#set_text (sprintf "%3.2f s" tsum); t.tl_records#set_text (sprintf "%3.2f s" trecords); t.tl_ac#set_text (sprintf "%3.2f s" tac); t.pr_sat#set_fraction (tsat /. total); t.pr_sat#set_text (sprintf "%2.0f %%" (tsat *. 100. /. total)); t.pr_match#set_fraction (tmatch /. total); t.pr_match#set_text (sprintf "%2.0f %%" (tmatch *. 100. /. total)); t.pr_cc#set_fraction (tcc /. total); t.pr_cc#set_text (sprintf "%2.0f %%" (tcc *. 100. /. total)); t.pr_arith#set_fraction (tarith /. total); t.pr_arith#set_text (sprintf "%2.0f %%" (tarith *. 100. /. total)); t.pr_arrays#set_fraction (tarrays /. total); t.pr_arrays#set_text (sprintf "%2.0f %%" (tarrays *. 100. /. total)); t.pr_sum#set_fraction (tsum /. total); t.pr_sum#set_text (sprintf "%2.0f %%" (tsum *. 100. /. total)); t.pr_records#set_fraction (trecords /. total); t.pr_records#set_text (sprintf "%2.0f %%" (trecords *. 100. /. total)); t.pr_ac#set_fraction (tac /. total); t.pr_ac#set_text (sprintf "%2.0f %%" (tac *. 100. /. total)); true let reset_timers timers_model = Timers.reset timers_model.timers; ignore (refresh_timers timers_model ()) let refresh_instances ({istore=istore} as inst_model) () = Hashtbl.iter (fun id (r, n, name, limit) -> let row, upd_info = match !r with | Some row -> row, false | None -> let row = istore#append () in r := Some row; row, true in let nb = !n in inst_model.max <- max inst_model.max nb; if upd_info then begin istore#set ~row ~column:inst_model.icol_icon `INFO; istore#set ~row ~column:inst_model.icol_desc name; let slimit = if !limit >= 0 then string_of_int !limit else "∞" in istore#set ~row ~column:inst_model.icol_limit slimit; end; istore#set ~row ~column:inst_model.icol_number nb; istore#set ~row ~column:inst_model.icol_tag id ) inst_model.h; true let add_inst ({h=h} as inst_model) orig = let id = Formula.id orig in let name = match Formula.view orig with | Formula.Lemma {Formula.name=n} when Pervasives.(<>) n "" -> n | _ -> string_of_int id in let r, n, limit, to_add = try let r, n, _, limit = Hashtbl.find h id in r, n, limit, false with Not_found -> ref None, ref 0, ref (-1), true in if !limit <> -1 && !limit < !n + 1 then false else begin incr n; if to_add then Hashtbl.add h id (r, n, name, limit); inst_model.max <- max inst_model.max !n; Thread.yield (); true end let reset_inst inst_model = Hashtbl.iter (fun _ (_, n, _, _) -> n := 0) inst_model.h; ignore (refresh_instances inst_model ()) let empty_sat_inst inst_model = inst_model.max <- 0; reset_inst inst_model; SAT.empty_with_inst (add_inst inst_model) exception Abort_thread exception Timeout let update_status image label buttonclean env d s steps = let satmode = (* smtfile() || smt2file() || satmode()*) false in match s with | FE.Unsat dep -> let time = Options.Time.value () in if not satmode then Loc.report std_formatter d.st_loc; if satmode then printf "@{unsat@}@." else printf "@{Valid@} (%2.4f) (%Ld)@." time steps; if proof () then begin printf "Proof:\n%a@." Explanation.print_proof dep; show_used_lemmas env dep end; image#set_stock `YES; label#set_text (sprintf " Valid (%2.2f s)" time); buttonclean#misc#show (); ignore(buttonclean#connect#clicked ~callback:(fun () -> prune_unused env)) | FE.Inconsistent -> if not satmode then (Loc.report std_formatter d.st_loc; fprintf fmt "Inconsistent assumption@.") else printf "unsat@."; image#set_stock `EXECUTE; label#set_text " Inconsistent assumption" | FE.Unknown t -> if not satmode then (Loc.report std_formatter d.st_loc; printf "I don't know.@.") else printf "unknown@."; image#set_stock `NO; label#set_text (sprintf " I don't know (%2.2f s)" (Options.Time.value())); if model () then pop_model t () | FE.Sat t -> if not satmode then Loc.report std_formatter d.st_loc; if satmode then printf "unknown (sat)@." else printf "I don't know@."; image#set_stock `NO; label#set_text (sprintf " I don't know (sat) (%2.2f s)" (Options.Time.value())); if model () then pop_model t () let update_aborted image label buttonstop buttonrun timers_model = function | Abort_thread -> Options.Time.unset_timeout (); Timers.update timers_model.timers; if debug () then fprintf fmt "alt-ergo thread terminated@."; image#set_stock `DIALOG_QUESTION; label#set_text " Process aborted"; buttonstop#misc#hide (); buttonrun#misc#show () | Timeout -> Options.Time.unset_timeout (); Timers.update timers_model.timers; if debug () then fprintf fmt "alt-ergo thread terminated (timeout)@."; image#set_stock `CUT; label#set_text " Timeout"; buttonstop#misc#hide (); buttonrun#misc#show () | e -> Options.Time.unset_timeout (); Timers.update timers_model.timers; let message = sprintf "Error: %s" (Printexc.to_string e) in if debug () then fprintf fmt "alt-ergo thread terminated@."; image#set_stock `DIALOG_ERROR; label#set_text (" "^message); buttonstop#misc#hide (); buttonrun#misc#show (); fprintf fmt "%s@." message; pop_error ~error:true ~message () let wrapper_update_status image label buttonclean env d s steps = GtkThread.sync (fun () -> update_status image label buttonclean env d s steps ) () let wrapper_update_aborted image label buttonstop buttonrun timers_model e = GtkThread.async (fun () -> update_aborted image label buttonstop buttonrun timers_model e ) () let wrapper_reset buttonstop buttonrun = GtkThread.async (fun () -> buttonstop#misc#hide (); buttonrun#misc#show () ) () let wrapper_refresh_instances inst_model = GtkThread.async (fun () -> ignore (refresh_instances inst_model ()) ) let wrapper_refresh_timers timers_model = GtkThread.async (fun () -> ignore (refresh_timers timers_model ()) ) let interrupt = ref None let vt_signal = match Sys.os_type with | "Win32" -> Sys.sigterm | _ -> Sys.sigvtalrm let force_interrupt old_action_ref n = (* This function is called just before the thread's timeslice ends *) if Pervasives.(=) (Some (Thread.id(Thread.self()))) !interrupt then raise Abort_thread; match !old_action_ref with | Sys.Signal_handle f -> f n | _ -> fprintf fmt "Not in threaded mode@." let rec kill_thread thread () = match !thread with | Some r -> interrupt := Some (Thread.id r); Thread.join r | _ -> interrupt := None let run_replay env = let ast = to_ast env.ast in if debug () then fprintf fmt "AST : \n-----\n%a@." print_typed_decl_list ast; let ast_pruned = [List.map (fun f -> f,true) ast] in Options.Time.start (); Options.Time.set_timeout (Options.timelimit ()); List.iter (fun dcl -> let cnf = Cnf.make dcl in ignore (Queue.fold (FE.process_decl FE.print_status) (empty_sat_inst env.insts, true, Explanation.empty) cnf) ) ast_pruned; Options.Time.unset_timeout () let run buttonrun buttonstop buttonclean inst_model timers_model image label thread env () = Profiling.init (); (* Install the signal handler: *) let old_action_ref = ref Sys.Signal_ignore in let old_action = Sys.signal vt_signal (Sys.Signal_handle (force_interrupt old_action_ref)) in old_action_ref := old_action; image#set_stock `EXECUTE; label#set_text " ..."; buttonstop#misc#show (); buttonrun#misc#hide (); buttonclean#misc#hide (); clear_used_lemmas_tags env; let ast = to_ast env.ast in if debug () then fprintf fmt "AST : \n-----\n%a@." print_typed_decl_list ast; let ast_pruned = [List.map (fun f -> f,true) ast] in (* refresh instances *) let to_id = GMain.Timeout.add ~ms:300 ~callback:(refresh_instances inst_model) in let ti_id = GMain.Timeout.add ~ms:500 ~callback:(refresh_timers timers_model) in reset_timers timers_model; thread := Some (Thread.create (fun () -> (try (* Thread.yield (); *) if debug () then fprintf fmt "Starting alt-ergo thread@."; Options.Time.start (); Options.Time.set_timeout (Options.timelimit ()); Options.set_timer_start (Timers.start timers_model.timers); Options.set_timer_pause (Timers.pause timers_model.timers); List.iter (fun dcl -> let cnf = Cnf.make dcl in ignore (Queue.fold (FE.process_decl (wrapper_update_status image label buttonclean env)) (empty_sat_inst inst_model, true, Explanation.empty) cnf) ) ast_pruned; Options.Time.unset_timeout () with e -> wrapper_update_aborted image label buttonstop buttonrun timers_model e ); if debug () then fprintf fmt "Send done signal to waiting thread@."; wrapper_reset buttonstop buttonrun; Thread.delay 0.001; GMain.Timeout.remove to_id; GMain.Timeout.remove ti_id; wrapper_refresh_instances inst_model (); wrapper_refresh_timers timers_model (); ) ()); Thread.yield () let remove_context env () = List.iter (fun (td, _) -> match td.c with | APredicate_def (_, _, _, _) -> toggle_prune env td | AAxiom (_, s, _) when String.length s = 0 || (Pervasives.(<>) s.[0] '_' && Pervasives.(<>) s.[0] '@') -> toggle_prune env td | _ -> () ) env.ast let set_ctrl env b key = let open GdkKeysyms in let k = GdkEvent.Key.keyval key in if k == _Control_L || k == _Control_R then (env.ctrl <- b; true) else false let empty_error_model () = let rcols = new GTree.column_list in let rcol_icon = rcols#add GtkStock.conv in let rcol_desc = rcols#add Gobject.Data.string in let rcol_line = rcols#add Gobject.Data.int in let rcol_type = rcols#add Gobject.Data.int in let rcol_color = rcols#add Gobject.Data.string in { some = false; rcols = rcols; rcol_icon = rcol_icon; rcol_desc = rcol_desc; rcol_line = rcol_line; rcol_type = rcol_type; rcol_color = rcol_color; rstore = GTree.list_store rcols; } let goto_error (view:GTree.view) error_model buffer (sv:GSourceView2.source_view) path column = let model = view#model in let row = model#get_iter path in let line = model#get ~row ~column:error_model.rcol_line in let iter_line = buffer#get_iter (`LINE (line-1)) in let iter_endline = iter_line#forward_line#backward_char in buffer#select_range iter_endline iter_line; ignore(sv#scroll_to_iter ~use_align:true ~yalign:0.1 iter_line) let create_error_view error_model buffer sv ~packing () = let view = GTree.view ~model:error_model.rstore ~packing () in let renderer = GTree.cell_renderer_pixbuf [] in let col = GTree.view_column ~title:"" ~renderer:(renderer, ["stock_id", error_model.rcol_icon]) () in ignore (view#append_column col); col#set_sort_column_id error_model.rcol_icon.GTree.index; let renderer = GTree.cell_renderer_text [] in let col = GTree.view_column ~title:"Line" ~renderer:(renderer, ["text", error_model.rcol_line]) () in ignore (view#append_column col); col#set_resizable true; col#set_sort_column_id error_model.rcol_line.GTree.index; let renderer = GTree.cell_renderer_text [] in let col = GTree.view_column ~title:"Description" ~renderer:(renderer, ["text", error_model.rcol_desc]) () in ignore (view#append_column col); col#set_resizable true; col#set_sort_column_id error_model.rcol_desc.GTree.index; ignore(view#connect#row_activated ~callback:(goto_error view error_model buffer sv)); view let goto_lemma (view:GTree.view) inst_model buffer (sv:GSourceView2.source_view) env path column = let model = view#model in let row = model#get_iter path in let id = model#get ~row ~column:inst_model.icol_tag in try let line, t = find_line id env.ast in let iter_line = buffer#get_iter (`LINE (line-1)) in let prev_line = buffer#get_iter (`LINE (line-2)) in buffer#place_cursor ~where:iter_line; ignore(sv#scroll_to_iter ~use_align:true ~yalign:0.1 prev_line); env.last_tag#set_properties [`BACKGROUND_SET false; `UNDERLINE_SET false]; t#set_property (`BACKGROUND "light blue"); env.last_tag <- t; with Not_found -> () let colormap = Gdk.Color.get_system_colormap () let set_color_inst inst_model renderer (istore:GTree.model) row = let id = istore#get ~row ~column:inst_model.icol_tag in let _, nb_inst, _, limit = Hashtbl.find inst_model.h id in (* let nb_inst = istore#get ~row ~column:inst_model.icol_number in *) (* let limit = istore#get ~row ~column:inst_model.icol_limit in *) let nb_inst = !nb_inst in let limit = !limit in if nb_inst = limit then renderer#set_properties [`FOREGROUND "blue"] else if inst_model.max <> 0 then let perc = (nb_inst * 65535) / inst_model.max in let red_n = Gdk.Color.alloc colormap (`RGB (perc, 0, 0)) in renderer#set_properties [`FOREGROUND_GDK red_n] else renderer#set_properties [`FOREGROUND_SET false]; Thread.yield () let create_inst_view inst_model env buffer sv ~packing () = let view = GTree.view ~model:inst_model.istore ~packing () in view#selection#set_mode `MULTIPLE; let renderer = GTree.cell_renderer_pixbuf [] in let col = GTree.view_column ~title:"" ~renderer:(renderer, ["stock_id", inst_model.icol_icon]) () in ignore (view#append_column col); col#set_sort_column_id inst_model.icol_icon.GTree.index; let renderer = GTree.cell_renderer_text [] in let col = GTree.view_column ~title:"#" ~renderer:(renderer, ["text", inst_model.icol_number]) () in ignore (view#append_column col); col#set_cell_data_func renderer (set_color_inst inst_model renderer); col#set_resizable true; col#set_sort_column_id inst_model.icol_number.GTree.index; let renderer = GTree.cell_renderer_text [`EDITABLE true] in ignore (renderer#connect#edited (fun path s -> let limit = try int_of_string s with Failure _ -> -1 in List.iter (fun path -> let row = inst_model.istore#get_iter path in let id = inst_model.istore#get ~row ~column:inst_model.icol_tag in let _, nb, name,l = Hashtbl.find inst_model.h id in if limit >= 0 then begin l := limit; inst_model.istore#set ~row ~column:inst_model.icol_limit (string_of_int limit); Gui_session.save env.actions (Gui_session.LimitLemma (id, name,limit)) end else begin l := -1; inst_model.istore#set ~row ~column:inst_model.icol_limit inf; Gui_session.save env.actions (Gui_session.UnlimitLemma (id, name)) end ) view#selection#get_selected_rows )); let col = GTree.view_column ~title:"limit" ~renderer:(renderer, ["text", inst_model.icol_limit]) () in ignore (view#append_column col); col#set_resizable true; col#set_sort_column_id inst_model.icol_limit.GTree.index; let renderer = GTree.cell_renderer_text [] in let col = GTree.view_column ~title:"Lemma" ~renderer:(renderer, ["text", inst_model.icol_desc]) () in ignore (view#append_column col); col#set_cell_data_func renderer (set_color_inst inst_model renderer); col#set_resizable true; col#set_sort_column_id inst_model.icol_desc.GTree.index; ignore(view#connect#row_activated ~callback:(goto_lemma view inst_model buffer sv env)); view let next_begins i buf found_all_tag = let iter = ref i in while !iter#compare buf#end_iter < 0 && not (!iter#begins_tag (Some found_all_tag)) do iter := !iter#forward_to_tag_toggle (Some found_all_tag) done; if !iter#compare buf#end_iter >= 0 then raise Not_found; !iter let prev_ends i buf found_all_tag = let iter = ref i in while !iter#compare buf#start_iter > 0 && not (!iter#ends_tag (Some found_all_tag)) do iter := !iter#backward_to_tag_toggle (Some found_all_tag) done; if !iter#compare buf#start_iter <= 0 then raise Not_found; !iter let search_next ?(backward=false) (sv:GSourceView2.source_view) (buf:sbuffer) found_tag found_all_tag () = try let iter = buf#get_iter_at_char buf#cursor_position in buf#remove_tag found_tag ~start:buf#start_iter ~stop:buf#end_iter; let i1 = if backward then prev_ends iter buf found_all_tag else next_begins iter buf found_all_tag in let i2 = if backward then i1#backward_to_tag_toggle (Some found_all_tag) else i1#forward_to_tag_toggle (Some found_all_tag) in buf#apply_tag found_tag ~start:i1 ~stop:i2; ignore(sv#scroll_to_iter ~use_align:true ~yalign:0.1 i1#backward_line); buf#place_cursor ~where:i2 with Not_found -> () let search_one buf str result iter found_all_tag = result := GSourceView2.iter_forward_search !iter [] ~start:buf#start_iter ~stop:buf#end_iter str; match !result with | None -> () | Some (i1, i2) -> buf#apply_tag found_all_tag ~start:i1 ~stop:i2; iter := i2 let search_all entry (sv:GSourceView2.source_view) (buf:sbuffer) found_tag found_all_tag () = buf#remove_tag found_tag ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag found_all_tag ~start:buf#start_iter ~stop:buf#end_iter; let str = entry#text in let iter = ref buf#start_iter in if Pervasives.(<>) str "" then let result = ref None in search_one buf str result iter found_all_tag; while !result != None do search_one buf str result iter found_all_tag done let start_gui () = Options.set_timers true; Options.set_thread_yield Thread.yield; (* TODO: crash : change this*) set_timeout (fun () -> printf "Timeout@."; raise Timeout); let w = GWindow.window ~title:"AltGr-Ergo" ~allow_grow:true ~allow_shrink:true ~position:`CENTER ~width:window_width ~height:window_height () in let lmanager = GSourceView2.source_language_manager ~default:true in let source_language = lmanager#language "alt-ergo" in let smanager = GSourceView2.source_style_scheme_manager ~default:true in let scheme = smanager#style_scheme "tango" in let file = get_file () in let typed_ast = FE.parse_and_typecheck file None in let main_vbox = GPack.vbox ~homogeneous:false ~border_width:0 ~packing:w#add () in let menubar = GMenu.menu_bar ~packing:main_vbox#pack () in let notebook = GPack.notebook ~border_width:0 ~tab_pos:`BOTTOM ~show_border:false ~enable_popup:true ~scrollable:true ~packing:main_vbox#add () in let note_search = Hashtbl.create 7 in let session_cin = try Some (open_in_bin (get_session_file())) with Sys_error _ -> None in let envs = List.fold_left (fun acc l -> let buf1 = match source_language with | Some language -> GSourceView2.source_buffer ~language ~highlight_syntax:true ~highlight_matching_brackets:true () | None -> GSourceView2.source_buffer () in let buf2 = match source_language with | Some language -> GSourceView2.source_buffer ~language ~highlight_syntax:true ~highlight_matching_brackets:true () | None -> GSourceView2.source_buffer () in buf1#set_style_scheme scheme; buf2#set_style_scheme scheme; let annoted_ast = annot buf1 l in if debug () then fprintf fmt "Computing dependencies ... "; let dep = make_dep annoted_ast in if debug () then fprintf fmt "Done@."; let text = List.fold_left (fun _ (td,_) -> match td.c with | AGoal (_, Thm, s, _) -> "goal "^s | AGoal (_, Check, s, _) -> "check "^s | AGoal (_, Cut, s, _) -> "cut "^s | _ -> "Empty" ) "" annoted_ast in let label = GMisc.label ~text () in let nb_page = ref 0 in let append g = nb_page := notebook#append_page ~tab_label:label#coerce g in let eventBox = GBin.event_box ~border_width:0 ~packing:append () in let vbox = GPack.vbox ~homogeneous:false ~border_width:0 ~packing:eventBox#add () in let rbox = GPack.vbox ~border_width:0 ~packing:vbox#add () in let toolbox = GPack.hbox ~border_width:0 ~packing:rbox#pack () in let toolbar = GButton.toolbar ~tooltips:true ~packing:toolbox#add () in toolbar#set_icon_size `DIALOG; let hb = GPack.paned `HORIZONTAL ~border_width:3 ~packing:rbox#add () in let vb1 = GPack.paned `VERTICAL ~border_width:3 ~packing:(hb#pack1 ~shrink:true ~resize:true) () in let vb2 = GPack.paned `VERTICAL ~border_width:3 ~packing:(hb#pack2 ~shrink:true ~resize:true) () in let fr1 = GBin.frame ~shadow_type:`ETCHED_OUT ~width:(60 * window_width / 100) ~height:(50 * window_height / 100) ~packing:(vb1#pack1 ~shrink:true ~resize:true) () in let fr2 = GBin.frame ~shadow_type:`ETCHED_OUT ~height:(15 * window_height / 100) ~packing:(vb2#pack1 ~shrink:true ~resize:true) () in let fr3 = GBin.frame ~shadow_type:`ETCHED_OUT ~show:false ~height:(5 * window_height / 100) ~packing:(vb1#pack2 ~shrink:true ~resize:true) () in let binfo = GPack.vbox ~border_width:0 ~packing:(vb2#pack2 ~shrink:true ~resize:true) () in let fr4 = GBin.frame ~shadow_type:`ETCHED_OUT ~packing:binfo#add () in let fr5 = GBin.frame ~shadow_type:`NONE ~packing:binfo#pack () in let table_timers = GPack.table ~columns:3 ~rows:8 ~row_spacings:1 ~col_spacings:8 ~border_width:4 ~packing:fr5#add () in let st = GMisc.statusbar ~has_resize_grip:false ~border_width:0 ~packing:vbox#pack () in let st_ctx = st#new_context ~name:"Type" in let error_model = empty_error_model () in let inst_model = empty_inst_model () in let timers_model = empty_timers_model table_timers in let resulting_ids = compute_resulting_ids annoted_ast in let actions = Gui_session.read_actions resulting_ids session_cin in let sw1 = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:fr1#add () in let tv1 = GSourceView2.source_view ~source_buffer:buf1 ~packing:(sw1#add) ~show_line_numbers:true ~wrap_mode:`NONE ~highlight_current_line:true () in let _ = tv1#misc#modify_font monospace_font in let _ = tv1#set_editable false in let sw2 = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:fr2#add () in let tv2 = GSourceView2.source_view ~source_buffer:buf2 ~packing:(sw2#add) ~show_line_numbers:false ~wrap_mode:`NONE ~highlight_current_line:true () in let _ = tv2#misc#modify_font monospace_font in let _ = tv2#set_editable false in let env = create_env buf1 tv1 buf2 tv2 error_model inst_model st_ctx annoted_ast dep actions resulting_ids in connect env; ignore (toolbar#insert_toggle_button ~text:" Remove context" ~icon:(GMisc.image ~stock:`CUT ~icon_size:`LARGE_TOOLBAR ())#coerce ~callback:(remove_context env) ()); let buttonrun = toolbar#insert_button ~text:" Run Alt-Ergo" ~icon:(GMisc.image ~stock:`EXECUTE ~icon_size:`LARGE_TOOLBAR() )#coerce () in let buttonstop = toolbar#insert_button ~text:" Abort" ~icon:(GMisc.image ~stock:`STOP ~icon_size:`LARGE_TOOLBAR() )#coerce () in buttonstop#misc#hide (); toolbar#insert_space (); let resultbox = GPack.hbox () in let result_image = GMisc.image ~icon_size:`LARGE_TOOLBAR ~stock:`DIALOG_QUESTION ~packing:resultbox#add () in let result_label = GMisc.label ~text:" " ~packing:resultbox#add () in ignore(toolbar#insert_widget resultbox#coerce); let buttonclean = toolbar#insert_button ~text:" Clean unused" ~icon:(GMisc.image ~stock:`CLEAR ~icon_size:`LARGE_TOOLBAR() )#coerce () in buttonclean#misc#hide (); let toolsearch = GButton.toolbar ~tooltips:true ~packing:(toolbox#pack ~fill:true) () in toolsearch#set_icon_size `DIALOG; let search_box = GPack.hbox ~spacing:5 ~border_width:5 () in ignore(GMisc.image ~icon_size:`LARGE_TOOLBAR ~stock:`FIND ~packing:search_box#add ()); let search_entry = GEdit.entry ~packing:search_box#add () in ignore(toolsearch#insert_widget search_box#coerce); let button_seach_forw = toolsearch#insert_button (* ~text:"Search" *) ~icon:(GMisc.image ~stock:`GO_DOWN ~icon_size:`LARGE_TOOLBAR() )#coerce () in let button_seach_back = toolsearch#insert_button (* ~text:"Search" *) ~icon:(GMisc.image ~stock:`GO_UP ~icon_size:`LARGE_TOOLBAR() )#coerce () in let found_all_tag = buf1#create_tag [`BACKGROUND "yellow"] in let found_tag = buf1#create_tag [`BACKGROUND "orange"] in ignore(search_entry#connect#changed ~callback:(search_all search_entry tv1 buf1 found_tag found_all_tag)); ignore(search_entry#event#connect#key_press ~callback:(fun k -> if GdkEvent.Key.keyval k = GdkKeysyms._Return then begin search_next tv1 buf1 found_tag found_all_tag (); true end else false )); ignore(button_seach_forw#connect#clicked ~callback:(search_next tv1 buf1 found_tag found_all_tag)); ignore(button_seach_back#connect#clicked ~callback:(search_next ~backward:true tv1 buf1 found_tag found_all_tag)); let sw3 = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:fr3#add () in ignore(create_error_view error_model env.buffer tv1 ~packing:sw3#add ()); add_to_buffer error_model env.buffer env.ast; env.buffer#place_cursor ~where:buf1#start_iter; if error_model.some then fr3#misc#show (); let sw4 = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:fr4#add () in ignore(create_inst_view inst_model env env.buffer tv1 ~packing:sw4#add ()); Gui_replay.replay_session env; ignore (refresh_instances env.insts ()); let thread = ref None in ignore(buttonrun#connect#clicked ~callback:(run buttonrun buttonstop buttonclean inst_model timers_model result_image result_label thread env)); ignore(buttonstop#connect#clicked ~callback:(kill_thread thread)); ignore(eventBox#event#connect#key_press ~callback:(set_ctrl env true)); ignore(eventBox#event#connect#key_release ~callback:(set_ctrl env false)); Hashtbl.add note_search !nb_page (search_entry, run buttonrun buttonstop buttonclean inst_model timers_model result_image result_label thread env); env::acc ) [] typed_ast in begin match session_cin with | Some c -> close_in c | None -> () end; let envs = List.rev envs in let file_entries = [ `I ("Save session", save_dialog "Cancel" envs); `S; `I ("Quit", quit envs) ] in let not_implemented _ = eprintf "Not implemented@." in let set_wrap_lines _ = List.iter (fun env -> if Pervasives.(=) env.goal_view#wrap_mode `NONE then ( env.goal_view#set_wrap_mode `CHAR; env.inst_view#set_wrap_mode `CHAR ) else ( env.goal_view#set_wrap_mode `NONE; env.inst_view#set_wrap_mode `NONE )) envs in let choose_font () = let font_win = GWindow.font_selection_dialog ~parent:w ~destroy_with_parent:true ~modal:true ~position:`CENTER_ON_PARENT () in ignore ( font_win#ok_button#connect#clicked (fun () -> set_font envs font_win#selection#font_name) ); ignore (font_win#run ()); ignore (font_win#misc#hide ()) in let debug_entries = [ `C ("SAT", debug_sat (), set_debug_sat); `S; `C ("CC", debug_cc (), set_debug_cc); `C ("Use", debug_use (), set_debug_use); `C ("UF", debug_uf (), set_debug_uf); `C ("AC", debug_ac (), set_debug_ac); `S; `C ("Arith", debug_arith (), set_debug_arith); `C ("Fourier-Motzkin", debug_fm (), set_debug_fm); `C ("Arrays", debug_arrays (), set_debug_arrays); `C ("Bit-vectors", debug_bitv (), set_debug_bitv); `C ("Sum", debug_sum (), set_debug_sum); `C ("Records", false, not_implemented); `S; `C ("Case split", debug_split (), set_debug_split); `C ("Replay proofs", debug_proof (), set_debug_proof); `C ("Typing", debug_typing (), set_debug_typing); `C ("Verbose", verbose (), set_verbose); ] in let options_entries = [ `C ("Unsat cores (proofs)", proof (), set_proof); `S; `C ("Model", model (), set_model); `C ("Complete model", complete_model (), set_complete_model); `C ("All models", all_models (), set_all_models); `S; `C ("Variables in triggers", triggers_var (), set_triggers_var); `C ("Greedy", greedy (), set_greedy); `C ("Contra congruence", not (nocontracongru ()), fun b -> set_nocontracongru (not b)); `S; `C ("Restricted", restricted (), set_restricted); `S; `C ("Wrap lines", false, set_wrap_lines); `S; `I ("Change font", choose_font); `I ("Increase font size", fun () -> increase_size envs); `I ("Decrease font size", fun () -> decrease_size envs); `I ("Reset font size", fun () -> reset_size envs); ] in let help_entries = [ `I ("About", show_about); ] in (* let entries = [ *) (* `M ("File", file_entries); *) (* `M ("Debug", debug_entries); *) (* `M ("Options", options_entries); *) (* `M ("Help", help_entries) *) (* ] in *) let create_menu label menubar = let item = GMenu.menu_item ~label ~packing:menubar#append () in GMenu.menu ~packing:item#set_submenu () in let menu = create_menu "File" menubar in GToolbox.build_menu menu ~entries:file_entries; let menu = create_menu "Debug" menubar in GToolbox.build_menu menu ~entries:debug_entries; let menu = create_menu "Options" menubar in GToolbox.build_menu menu ~entries:options_entries; let menu = create_menu "Help" menubar in GToolbox.build_menu menu ~entries:help_entries; let focus_search () = let p = notebook#current_page in let e, _ = Hashtbl.find note_search p in e#misc#grab_focus () in let launch_run () = let p = notebook#current_page in let _, r = Hashtbl.find note_search p in r () in let mod_mask = [`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] in let key_press ev = let key_ev = GdkEvent.Key.keyval ev in let mods_ev = List.filter (fun m -> not (List.mem m mod_mask)) (GdkEvent.Key.state ev) in match mods_ev with | [`CONTROL] -> (match key_ev with | k when k = GdkKeysyms._q -> quit envs (); true | k when k = GdkKeysyms._s -> save_dialog "Cancel" envs (); true | k when k = GdkKeysyms._f -> focus_search (); true | k when k = GdkKeysyms._r -> launch_run (); true | k when k = GdkKeysyms._equal || k = GdkKeysyms._plus -> increase_size envs; true | k when k = GdkKeysyms._minus -> decrease_size envs; true | k when k = GdkKeysyms._0 || k = GdkKeysyms._KP_0 -> reset_size envs; true | _ -> false) | _ -> false in ignore (w#event#connect#key_press ~callback:(key_press)); ignore(w#connect#destroy ~callback:(quit envs)); w#show (); (* Thread.join(GtkThread.start ()); *) GtkThread.main () let start_replay session_cin = let file = get_file () in let typed_ast = FE.parse_and_typecheck file None in List.iter (fun l -> let buf1 = GSourceView2.source_buffer () in let annoted_ast = annot buf1 l in let error_model = empty_error_model () in let inst_model = empty_inst_model () in let resulting_ids = compute_resulting_ids annoted_ast in let actions = Gui_session.read_actions resulting_ids session_cin in (* cradingue *) let env = create_replay_env buf1 error_model inst_model annoted_ast actions resulting_ids in add_to_buffer error_model env.buffer env.ast; Gui_replay.replay_session env; run_replay env ) typed_ast; begin match session_cin with | Some c -> close_in c | None -> () end let _ = try if replay() then start_replay (Some (open_in_bin (get_session_file()))) else start_gui () with | Sys_error _ -> start_gui () | Util.Timeout -> Format.eprintf "Timeout@."; exit 142 alt-ergo-1.30/src/main/frontend.mli0000644000175000001440000000423313014515065015552 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Typed module type S = sig type sat_env type output = Unsat of Explanation.t | Inconsistent | Sat of sat_env | Unknown of sat_env val process_decl: (Commands.sat_tdecl -> output -> int64 -> unit) -> sat_env * bool * Explanation.t -> Commands.sat_tdecl -> sat_env * bool * Explanation.t val parse_and_typecheck: string -> Lexing.lexbuf option -> ((int tdecl, int) annoted * Why_typing.env) list list val print_status : Commands.sat_tdecl -> output -> int64 -> unit end module Make (SAT: Sat_solvers.S) : S with type sat_env = SAT.t alt-ergo-1.30/src/main/main_text.ml0000644000175000001440000000711513014515065015554 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Typed open Lexing open Format open Options module SAT = (val (Sat_solvers.get_current ()) : Sat_solvers.S) module FE = Frontend.Make (SAT) let timers = Timers.empty () let () = (* what to do with Ctrl+C ? *) Sys.set_signal Sys.sigint(*-6*) (Sys.Signal_handle (fun _ -> if Options.profiling() then Profiling.switch () else (print_endline "User wants me to stop."; exit 1) ) ) let () = (* put the test here because Windows does not handle Sys.Signal_handle correctly *) if Options.profiling() then List.iter (fun sign -> Sys.set_signal sign (Sys.Signal_handle (fun _ -> Profiling.print true (SAT.get_steps ()) timers fmt; exit 1 ) ) )[ Sys.sigterm (*-11*); Sys.sigquit (*-9*)] let () = (* put the test here because Windows does not handle Sys.Signal_handle correctly *) if Options.profiling() then Sys.set_signal Sys.sigprof (*-21*) (Sys.Signal_handle (fun _ -> Profiling.print false (SAT.get_steps ()) timers fmt; ) ) let () = try Options.Time.start (); Options.Time.set_timeout (Options.timelimit ()); if Options.profiling () then begin Timers.reset timers; assert (Options.timers()); Options.set_timer_start (Timers.start timers); Options.set_timer_pause (Timers.pause timers); Profiling.init (); end; (*Options.parse_args ();*) let file = get_file () in let d = FE.parse_and_typecheck file None in let d = List.map (fun d -> Cnf.make (List.map (fun (f, env) -> f, true) d)) d in List.iter (fun cnf -> SAT.reset_refs (); ignore (Queue.fold (FE.process_decl FE.print_status) (SAT.empty (), true, Explanation.empty) cnf) ) d; Options.Time.unset_timeout (); if Options.profiling() then Profiling.print true (SAT.get_steps ()) timers fmt; with Util.Timeout -> Format.eprintf "Timeout@."; exit 142 alt-ergo-1.30/src/gui/0000755000175000001440000000000013014515065013066 5ustar rtusersalt-ergo-1.30/src/gui/why_connected.ml0000644000175000001440000007676013014515065016271 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Why_annoted open Lexing open Format open Options open Gui_session let prune ?(register=true) env r = r.pruned <- true; if register then save env.actions (Prune r.id); r.tag#set_property (`FOREGROUND "light gray") let incorrect_prune ?(register=true) env r = r.pruned <- true; if register then save env.actions (IncorrectPrune r.id); r.tag#set_property (`FOREGROUND "tomato") let unprune ?(register=true) env r = r.pruned <- false; if register then save env.actions (Unprune r.id); r.tag#set_property (`FOREGROUND_SET false) let rec prune_dep env r = prune env r; let deps = match find_tag_inversedeps env.dep r.tag with | None -> [] | Some d -> d in List.iter (fun d -> prune_dep env d) deps let rec unprune_dep env r = unprune env r; let deps = match find_tag_deps env.dep r.tag with | None -> [] | Some d -> d in List.iter (fun d -> unprune_dep env d) deps let toggle_incorrect_prune env r = if r.pruned then unprune env r else incorrect_prune env r let toggle_prune env r = if r.pruned then unprune env r else prune env r let reset_search_tags env = List.iter (fun t -> t#set_property (`BACKGROUND_SET false)) env.search_tags; env.search_tags <- [] let search_using t sbuf env = match find t sbuf env.ast with | None -> () | Some an -> match an with | AD (r, _) -> let tags1 = findtags_using r.c env.ast in let tags2 = findtags_dep_adecl r.c env.ast in List.iter (fun t -> t#set_property (`BACKGROUND "gold")) tags1; List.iter (fun t -> t#set_property (`BACKGROUND "orange")) tags2; env.search_tags <- List.rev_append tags1 tags2; | AT {c = at} -> let tags = findtags_dep at env.ast in env.search_tags <- tags; List.iter (fun t -> t#set_property (`BACKGROUND "orange")) tags | AF (aaf, _) -> let tags = findtags_dep_aform aaf.c env.ast in env.search_tags <- tags; List.iter (fun t -> t#set_property (`BACKGROUND "orange")) tags | QF _ -> () (* let hand_cursor () = Gdk.Cursor.create `TARGET *) (* let arrow_cursor () = Gdk.Cursor.create `ARROW *) let set_select env sbuf = () (* match env.start_select, env.stop_select with *) (* | Some b, Some e -> *) (* sbuf#select_range *) (* (sbuf#get_iter (`OFFSET b)) (sbuf#get_iter (`OFFSET e)) *) (* (\* | None, Some _ -> *\) *) (* (\* if sbuf#has_selection then *\) *) (* (\* let ib, _ = sbuf#selection_bounds in *\) *) (* (\* env.start_select <- Some ib#offset; *\) *) (* (\* set_select env sbuf *\) *) (* (\* | Some _, None -> *\) *) (* (\* if sbuf#has_selection then *\) *) (* (\* let _, ie = sbuf#selection_bounds in *\) *) (* (\* env.stop_select <- Some ie#offset; *\) *) (* (\* set_select env sbuf *\) *) (* | _ -> () *) let tag_callback t env sbuf ~origin:y z i = let ofs = (new GText.iter i)#offset in match GdkEvent.get_type z with | `MOTION_NOTIFY -> if List.mem env.last_tag env.search_tags then env.last_tag#set_properties [`BACKGROUND "gold"; `UNDERLINE_SET false] (* else if List.mem env.last_tag env.proof_tags then *) (* env.last_tag#set_properties *) (* [`BACKGROUND "lime green"; `UNDERLINE_SET false] *) (* else if List.mem env.last_tag env.proof_toptags then *) (* env.last_tag#set_properties *) (* [`BACKGROUND "pale green"; `UNDERLINE_SET false] *) else env.last_tag#set_properties [`BACKGROUND_SET false; `UNDERLINE_SET false]; if env.ctrl then begin t#set_properties [`BACKGROUND "turquoise1"; `UNDERLINE `SINGLE] end else begin t#set_property (`BACKGROUND "light blue") end; env.last_tag <- t; env.stop_select <- Some ofs; set_select env sbuf; true | `TWO_BUTTON_PRESS -> begin match find t sbuf env.ast with | None -> () | Some an -> match an with | AD (r,_) -> if env.ctrl then if r.pruned then unprune_dep env r else prune_dep env r else toggle_prune env r | AF (r, Some parent) -> begin match parent.c, parent.polarity with | AFop (AOPand, _), false | AFop (AOPor, _), true | AFop (AOPimp, _), true | AFop (AOPiff, _), _ -> toggle_incorrect_prune env r | _ -> toggle_prune env r end | AF (r, None) -> toggle_prune env r | AT r -> toggle_prune env r | QF _ -> () end; true | `BUTTON_PRESS -> let z = GdkEvent.Button.cast z in let captured = if GdkEvent.Button.button z = 1 then begin reset_search_tags env; if env.ctrl then (search_using t sbuf env; true) else begin let tyt = match find t sbuf env.ast with | Some (AT at) -> fprintf str_formatter ": %a" Ty.print_full at.c.at_ty; flush_str_formatter () | Some (AF _) -> ": formula" | Some (QF _) -> ": quantified formula" | Some (AD ({c = AAxiom _}, _)) -> ": Axiom" | Some (AD ({c = AGoal _}, _)) -> ": Goal" | Some (AD ({c = ALogic _}, _)) -> ": Logic declaration" | Some (AD ({c = APredicate_def _}, _)) -> ": Predicate definition" | Some (AD ({c = AFunction_def _}, _)) -> ": Function definition" | Some (AD ({c = ATypeDecl _}, _)) -> ": Type declaration" | _ -> "" in env.st_ctx#pop (); ignore(env.st_ctx#push tyt); true end end else false in env.start_select <- Some ofs; set_select env sbuf; captured | `BUTTON_RELEASE -> env.start_select <- None; env.stop_select <- None; set_select env sbuf; false | _ -> false let term_callback t env sbuf ~origin:y z i = if tag_callback t env sbuf ~origin:y z i then true else match GdkEvent.get_type z with | `BUTTON_PRESS -> let z = GdkEvent.Button.cast z in if GdkEvent.Button.button z = 1 then begin let tyt = match find t sbuf env.ast with | Some (AT at) -> fprintf str_formatter ": %a" Ty.print at.c.at_ty; flush_str_formatter () | _ -> "" in env.st_ctx#pop (); ignore(env.st_ctx#push tyt); true end else false | _ -> false let rec list_uquant_vars_in_form = function | AFatom _ -> [] | AFop (op, aafl) -> List.fold_left (fun l aaf -> l@(list_uquant_vars_in_form aaf.c)) [] aafl | AFforall aqf -> let l = list_uquant_vars_in_form aqf.c.aqf_form.c in if aqf.polarity then aqf.c.aqf_bvars@l else l | AFexists aqf -> let l = list_uquant_vars_in_form aqf.c.aqf_form.c in if not aqf.polarity then aqf.c.aqf_bvars@l else l | AFlet (upvars, s, at, aaf) -> list_uquant_vars_in_form aaf.c | AFnamed (_, aaf) -> list_uquant_vars_in_form aaf.c let rec list_vars_in_form = function | AFatom _ -> [] | AFop (op, aafl) -> List.fold_left (fun l aaf -> l@(list_vars_in_form aaf.c)) [] aafl | AFforall aqf | AFexists aqf -> aqf.c.aqf_bvars@(list_vars_in_form aqf.c.aqf_form.c) | AFlet (upvars, s, at, aaf) -> list_vars_in_form aaf.c | AFnamed (_, aaf) -> list_vars_in_form aaf.c let rec is_quantified_term vars at = match at.at_desc with | ATconst _ -> false | ATvar s -> List.fold_left (fun b (s',_) -> b || (Symbols.equal s s')) false vars | ATapp (_, atl) -> List.fold_left (fun b at -> b || is_quantified_term vars at) false atl | ATget (at1, at2) | ATconcat (at1, at2) | ATinfix (at1, _, at2) -> is_quantified_term vars at1 || is_quantified_term vars at2 | ATdot (at, _) | ATprefix (_, at) | ATnamed (_, at) -> is_quantified_term vars at | ATextract (at1, at2, at3) | ATset (at1, at2, at3) -> is_quantified_term vars at1 || is_quantified_term vars at2 || is_quantified_term vars at3 | ATlet (s', at1, at2) -> let nvars = List.filter (fun (s'',_) -> not (Symbols.equal s' s'')) vars in is_quantified_term vars at1 || is_quantified_term nvars at2 | ATrecord r -> List.fold_left (fun b (_, at) -> b || is_quantified_term vars at) false r let unquantify_aaterm (buffer:sbuffer) at = new_annot buffer at.c (Why_typing.new_id ()) (tag buffer) let unquantify_aatom (buffer:sbuffer) = function | AAtrue -> AAtrue | AAfalse -> AAfalse | AAeq aatl -> AAeq (List.map (unquantify_aaterm buffer) aatl) | AAneq aatl -> AAneq (List.map (unquantify_aaterm buffer) aatl) | AAdistinct aatl -> AAdistinct (List.map (unquantify_aaterm buffer) aatl) | AAle aatl -> AAle (List.map (unquantify_aaterm buffer) aatl) | AAlt aatl -> AAlt (List.map (unquantify_aaterm buffer) aatl) | AApred a -> AApred a | AAbuilt (h,aatl) -> AAbuilt (h, (List.map (unquantify_aaterm buffer) aatl)) let rec aterm_used_vars goal_vars at = match at.at_desc with | ATconst _ -> [] | ATvar s -> (try [List.find (fun (s',_) -> Symbols.equal s s') goal_vars] with Not_found -> []) | ATapp (_, atl) -> List.fold_left (fun l at -> aterm_used_vars goal_vars at @ l) [] atl | ATdot (at, _) | ATprefix (_, at) | ATlet (_, _, at) | ATnamed (_, at) -> aterm_used_vars goal_vars at | ATinfix (at1, _, at2) | ATget (at1, at2) | ATconcat (at1, at2) -> (aterm_used_vars goal_vars at1)@(aterm_used_vars goal_vars at2) | ATset (at1, at2, at3) | ATextract (at1, at2, at3) -> (aterm_used_vars goal_vars at1)@ (aterm_used_vars goal_vars at2)@ (aterm_used_vars goal_vars at3) | ATrecord r -> List.fold_left (fun l (_, at) -> aterm_used_vars goal_vars at @ l) [] r let rec unquantify_aform (buffer:sbuffer) tyenv vars_entries used_vars goal_vars f pol = let ptag = (tag buffer) in let c, ve, goal_used = match f, pol with | AFatom aa, _ -> AFatom (unquantify_aatom buffer aa), vars_entries, [] | AFop (op, afl), _ -> let nafl, ve, goal_used = List.fold_left (fun (nafl, ve, gu) af -> let res, ve, gu' = unquantify_aform buffer tyenv ve used_vars goal_vars af.c af.polarity in (res::nafl, ve, gu'@gu)) ([], vars_entries, []) afl in AFop (op, List.rev nafl), ve, goal_used | AFforall aaqf, true | AFexists aaqf, false -> let {aqf_bvars = bv; aqf_upvars = uv; aqf_triggers = atll; aqf_form = af}= aaqf.c in let nbv, used, goal_used, ve, _, lets = List.fold_left (fun (nbv, used, goal_used, ve, uplet, lets) v -> let ((s, _) as v'), e = List.hd ve in let cdr_ve = List.tl ve in assert (Pervasives.(=) v v'); if String.length e == 0 then (v'::nbv, used, goal_used, cdr_ve, v'::uplet, lets) else let lb = Lexing.from_string e in let lexpr = Why_parser.lexpr Why_lexer.token lb in let at, gu = try let tt = Why_typing.term tyenv uplet lexpr in annot_of_tterm buffer tt, [] with Errors.Error _ -> let gv = List.fold_left (fun acc v -> if List.mem v uplet then acc else v::acc) [] goal_vars in let tt = Why_typing.term tyenv (uplet@gv) lexpr in let at = annot_of_tterm buffer tt in at, aterm_used_vars gv at.c in (nbv, v'::used, gu@goal_used, cdr_ve, v'::uplet, (uplet, s, at)::lets)) ([], [], [], vars_entries, uv, []) bv in let aform, ve, gu = unquantify_aform buffer tyenv ve used goal_vars af.c af.polarity in let goal_used = gu@goal_used in let add_lets afc lets = List.fold_left (fun af (u, s, at) -> new_annot buffer (AFlet (u, s, at.c, af)) (Why_typing.new_id ()) (tag buffer)) afc lets in if nbv == [] then (add_lets aform lets).c, ve, goal_used else let aqf_triggers = List.map (fun (l,b) -> List.map (unquantify_aaterm buffer)l, b) atll in let aqf_triggers = List.filter (fun (aatl,_) -> (* TODO : change nbv with something else *) List.filter (fun aat -> is_quantified_term nbv aat.c) aatl != [] ) aqf_triggers in if aqf_triggers == [] then (add_lets aform lets).c, ve, goal_used else let c = { aqf_bvars = nbv; aqf_upvars = List.filter (fun v -> not (List.mem v used_vars)) uv; aqf_triggers = aqf_triggers; aqf_form = add_lets aform lets} in (match f with | AFforall _ -> AFforall (new_annot buffer c (Why_typing.new_id ()) (tag buffer)), ve, goal_used | AFexists _ -> AFexists (new_annot buffer c (Why_typing.new_id ()) (tag buffer)), ve, goal_used | _ -> assert false) | AFforall aaqf, false | AFexists aaqf, true -> let naqf_form, ve, goal_used = unquantify_aform buffer tyenv vars_entries used_vars goal_vars aaqf.c.aqf_form.c aaqf.c.aqf_form.polarity in let c = { aaqf.c with aqf_form = naqf_form } in (match f with | AFforall _ -> AFforall (new_annot buffer c (Why_typing.new_id ()) (tag buffer)), ve, goal_used | AFexists _ -> AFexists (new_annot buffer c (Why_typing.new_id ()) (tag buffer)), ve, goal_used | _ -> assert false) | AFlet (uv, s, at, aaf), _ -> let naaf, ve, goal_used = unquantify_aform buffer tyenv vars_entries used_vars goal_vars aaf.c aaf.polarity in AFlet (List.filter (fun v -> not (List.mem v used_vars)) uv, s, at, naaf), ve, goal_used | AFnamed (n, aaf), _ -> let naaf, ve, goal_used = unquantify_aform buffer tyenv vars_entries used_vars goal_vars aaf.c aaf.polarity in AFnamed (n, naaf), ve, goal_used in new_annot buffer c (Why_typing.new_id ()) ptag, ve, goal_used let make_instance (buffer:sbuffer) vars entries afc goal_form tyenv = let goal_vars = list_vars_in_form goal_form.c in if debug () then List.iter (fun (v,e) -> eprintf "%a -> %s@." Symbols.print_clean (fst v) e) (List.combine vars (List.rev entries)); let aform, _, goal_used = unquantify_aform buffer tyenv (List.combine vars (List.rev entries)) [] goal_vars afc true in aform, goal_used exception UncoveredVar of (Symbols.t * Ty.t) type nestedq = Forall of aform annoted | Exists of aform annoted let rec least_nested_form used_vars af = match used_vars, af.c with | [], _ -> Exists af | v::r, AFatom _ -> raise(UncoveredVar v) | v::r, AFop (op, aafl) -> let rec least_list = function | [] -> raise(UncoveredVar v) | af::l -> try least_nested_form used_vars af with UncoveredVar _ -> least_list l in least_list aafl | _, AFforall aqf -> let not_covered = List.fold_left (fun l v -> if List.mem v aqf.c.aqf_bvars then l else v::l (*XXX*) ) [] used_vars in if not_covered == [] then Forall aqf.c.aqf_form else least_nested_form not_covered aqf.c.aqf_form | _, AFexists aqf -> let not_covered = List.fold_left (fun l v -> if List.mem v aqf.c.aqf_bvars then l else v::l (*XXX*) ) [] used_vars in if not_covered == [] then Exists aqf.c.aqf_form else least_nested_form not_covered aqf.c.aqf_form | _, AFlet (upvars, s, at, af) -> least_nested_form used_vars af | _, AFnamed (_, af) -> least_nested_form used_vars af let rec add_instance_aux ?(register=true) env id af aname vars entries = let ptag = (tag env.inst_buffer) in let goal_form, tyenv, loc = let rec find_goal = function | [] -> raise Not_found | [gt] -> gt | x::r -> find_goal r in let g, tyenv = find_goal env.ast in match g.c with | AGoal (loc, _, _, f) -> f, tyenv, loc | _ -> raise Not_found in let instance, used_vars = make_instance env.inst_buffer vars entries af goal_form tyenv in let ln_form = least_nested_form used_vars goal_form in env.inst_buffer#place_cursor ~where:env.inst_buffer#end_iter; if Pervasives.(=) ln_form (Exists goal_form) then begin let hy = AAxiom (loc, (sprintf "%s%s" "_instance_" aname), instance.c) in let ahy = new_annot env.inst_buffer hy instance.id ptag in let rev_ast = List.rev env.ast in let rev_ast = match rev_ast with | (g,te)::l -> (g,te)::(ahy, te)::l | _ -> assert false in env.ast <- List.rev rev_ast; connect_tag env env.inst_buffer ahy.tag; connect_aaform env env.inst_buffer instance; add_to_buffer env.errors env.inst_buffer [ahy, tyenv] end else begin let instance = new_annot env.inst_buffer instance.c instance.id ptag in begin match ln_form with | Exists lnf -> lnf.c <- AFop (AOPand, [instance; {lnf with c = lnf.c}]) | Forall lnf -> lnf.c <- AFop (AOPimp, [instance; {lnf with c = lnf.c}]) end; env.inst_buffer#insert ~tags:[instance.tag] ("instance "^aname^": \n"); connect_aaform env env.inst_buffer instance; env.inst_buffer#insert (String.make indent_size ' '); add_aaform env.errors env.inst_buffer 1 [] instance; env.inst_buffer#insert "\n\n"; end; if register then save env.actions (AddInstance (id, aname, entries)) and add_instance_entries ?(register=true) env id af aname vars (entries:GEdit.entry list) = let entries = List.map (fun e -> e#text) entries in add_instance_aux ~register env id af aname vars entries and add_instance ?(register=true) env id af aname entries = add_instance_aux ~register env id af aname (list_uquant_vars_in_form af) entries and popup_axiom t env offset () = let pop_w = GWindow.dialog ~title:"Instantiate axiom" ~allow_grow:true ~position:`MOUSE ~width:400 () (* ~icon:(GdkPixbuf.from_xpm_data Logo.xpm_logo) () *) in let bbox = GPack.button_box `HORIZONTAL ~border_width:5 ~layout:`END ~child_height:20 ~child_width:85 ~spacing:10 ~packing:pop_w#action_area#add () in let button_ok = GButton.button ~packing:bbox#add () in let phbox = GPack.hbox ~packing:button_ok#add () in ignore(GMisc.image ~stock:`OK ~packing:phbox#add ()); ignore(GMisc.label ~text:"OK" ~packing:phbox#add ()); let button_cancel = GButton.button ~packing:bbox#add () in let phbox = GPack.hbox ~packing:button_cancel#add () in ignore(GMisc.image ~stock:`CANCEL ~packing:phbox#add ()); ignore(GMisc.label ~text:"Cancel" ~packing:phbox#add ()); let vars, entries, id, af, aname = match find t env.buffer env.ast with | Some (AD (atd, tyenv)) -> begin match atd.c with | AAxiom (_, aname, af) -> pop_w#set_title ("Instantiate axiom "^aname) | APredicate_def (_, aname,_ , af) -> pop_w#set_title ("Instantiate predicate "^aname) | _ -> assert false end; begin match atd.c with | AAxiom (_, aname, af) | APredicate_def (_, aname,_ , af) -> let vars = list_uquant_vars_in_form af in let rows = List.length vars in let table = GPack.table ~rows ~columns:2 ~homogeneous:false ~border_width:5 ~packing:pop_w#vbox#add () in let entries,_ = List.fold_left (fun (entries,i) (s,ty) -> fprintf str_formatter "%a : %a = " Symbols.print_clean s Ty.print ty; let text = flush_str_formatter () in ignore( GMisc.label ~text ~xalign:1.0 ~packing:(table#attach ~left:0 ~top:i) ()); let entries = (GEdit.entry ~text:"" ~packing:(table#attach ~left:1 ~top:i ~expand:`BOTH ~shrink:`BOTH) () )::entries in entries, i+1 ) ([],0) vars in vars, entries, atd.id, af, aname | _ -> assert false end | _ -> assert false in let errors_l = GMisc.label ~text:"" ~packing:pop_w#vbox#pack () in errors_l#misc#modify_fg [`NORMAL, `NAME "red"]; errors_l#misc#hide (); ignore(button_ok#connect#clicked ~callback: (fun () -> try add_instance_entries env id af aname vars entries; pop_w#destroy () with | Why_lexer.Lexical_error s -> errors_l#set_text ("Lexical error"); errors_l#misc#show () | Parsing.Parse_error -> errors_l#set_text ("Syntax error"); errors_l#misc#show () | Errors.Error (e,_) -> fprintf str_formatter "Typing error : %a" Errors.report e; errors_l#set_text (flush_str_formatter ()); errors_l#misc#show () )); ignore(button_cancel#connect#clicked ~callback: pop_w#destroy); pop_w#show () and axiom_callback t env ~origin:y z i = let ni = new GText.iter i in let offset = ni#offset in if tag_callback t env env.buffer ~origin:y z i then true else begin match GdkEvent.get_type z with | `BUTTON_PRESS -> let z = GdkEvent.Button.cast z in if GdkEvent.Button.button z = 3 then let menu = GMenu.menu () in let image = GMisc.image ~stock:`ADD () in let menuitem = GMenu.image_menu_item ~image ~label:"Instanciate axiom ..." ~packing:menu#append () in ignore(menuitem#connect#activate ~callback:(popup_axiom t env offset)); menu#popup ~button:3 ~time:(GdkEvent.Button.time z); true else false | _ -> false end and add_trigger ?(register=true) t qid env str offset (sbuf:sbuffer) = let iter = sbuf#get_iter (`OFFSET offset) in match sbuf#forward_iter_to_source_mark ~category:(sprintf "trigger_%d" qid) iter with | true -> begin match find_decl t sbuf env.ast, find t sbuf env.ast with | Some (AD (_, tyenv)), Some (QF qf) -> let tags = iter#tags in let iter = sbuf#get_iter (`OFFSET (iter#offset - 2)) in let lb = Lexing.from_string str in let lexprs, _ = Why_parser.trigger Why_lexer.token lb in let atl = List.fold_right (fun lexpr l-> let tt = Why_typing.term tyenv (qf.c.aqf_upvars@qf.c.aqf_bvars) lexpr in let at = annot_of_tterm sbuf tt in at.tag#set_priority (t#priority - 1); connect_aaterm env sbuf connect_tag at; at::l ) lexprs [] in if qf.c.aqf_triggers != [] then sbuf#insert ~iter ~tags " | "; add_aaterm_list_at sbuf tags iter "," atl; qf.c.aqf_triggers <- qf.c.aqf_triggers@[atl,true]; if register then save env.actions (AddTrigger (qf.id, Pervasives.(=) sbuf env.inst_buffer, str)); commit_tags_buffer sbuf | _ -> assert false end | false -> () and readd_trigger ?(register=true) env id str inst_buf = try match findbyid id env.ast with | QF qf -> let sbuf = if inst_buf then env.inst_buffer else env.buffer in add_trigger ~register qf.tag id env str 0 sbuf | _ -> assert false with Not_found -> () and popup_trigger t qid env (sbuf:sbuffer) offset () = let pop_w = GWindow.dialog ~title:"Add new (multi) trigger" ~allow_grow:true ~width:400 ~height:100 () (* ~icon:(GdkPixbuf.from_xpm_data Logo.xpm_logo) () *) in let bbox = GPack.button_box `HORIZONTAL ~border_width:5 ~layout:`END ~child_height:20 ~child_width:85 ~spacing:10 ~packing:pop_w#action_area#add () in let button_ok = GButton.button ~packing:bbox#add () in let phbox = GPack.hbox ~packing:button_ok#add () in ignore(GMisc.image ~stock:`OK ~packing:phbox#add ()); ignore(GMisc.label ~text:"OK" ~packing:phbox#add ()); let button_cancel = GButton.button ~packing:bbox#add () in let phbox = GPack.hbox ~packing:button_cancel#add () in ignore(GMisc.image ~stock:`CANCEL ~packing:phbox#add ()); ignore(GMisc.label ~text:"Cancel" ~packing:phbox#add ()); let lmanager = GSourceView2.source_language_manager ~default:true in let source_language = lmanager#language "alt-ergo" in let buf1 = match source_language with | Some language -> GSourceView2.source_buffer ~language ~highlight_syntax:true ~highlight_matching_brackets:true () | None -> GSourceView2.source_buffer () in let sw1 = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:pop_w#vbox#add () in let tv1 = GSourceView2.source_view ~source_buffer:buf1 ~packing:(sw1#add) ~show_line_numbers:true ~wrap_mode:`CHAR() in let _ = tv1#misc#modify_font monospace_font in let _ = tv1#set_editable true in let errors_l = GMisc.label ~text:"" ~packing:pop_w#vbox#pack () in errors_l#misc#modify_fg [`NORMAL, `NAME "red"]; errors_l#misc#hide (); ignore(button_ok#connect#clicked ~callback: (fun () -> try let str = buf1#get_text () in add_trigger t qid env str offset sbuf; pop_w#destroy () with | Why_lexer.Lexical_error s -> errors_l#set_text ("Lexical error"); errors_l#misc#show () | Parsing.Parse_error -> errors_l#set_text ("Syntax error"); errors_l#misc#show () | Errors.Error (e,_) -> fprintf str_formatter "Typing error : %a" Errors.report e; errors_l#set_text (flush_str_formatter ()); errors_l#misc#show () )); ignore(button_cancel#connect#clicked ~callback: pop_w#destroy); pop_w#show () and triggers_callback t qid env sbuf ~origin:y z i = let ni = new GText.iter i in let offset = ni#offset in if tag_callback t env sbuf ~origin:y z i == true then true else begin match GdkEvent.get_type z with | `BUTTON_PRESS -> let z = GdkEvent.Button.cast z in if GdkEvent.Button.button z = 3 then let menu = GMenu.menu () in let image = GMisc.image ~stock:`ADD () in let menuitem = GMenu.image_menu_item ~image ~label:"Add trigger(s) ..." ~packing:menu#append () in ignore(menuitem#connect#activate ~callback:(popup_trigger t qid env sbuf offset)); menu#popup ~button:3 ~time:(GdkEvent.Button.time z); true else false | _ -> false end (* let triggers_tag (buffer:sbuffer) = *) (* let t = buffer#create_tag [`EDITABLE true; `BACKGROUND "orange"] in *) (* ignore (t#connect#event ~callback:(set_mark t buffer)); *) (* (\* ignore (t#connect#event ~callback:(fetch_text t buffer)); *\) *) (* t *) and connect_tag env sbuf t = ignore (t#connect#event ~callback:(tag_callback t env sbuf)) and connect_term env sbuf t = ignore (t#connect#event ~callback:(term_callback t env sbuf)) and connect_trigger_tag env sbuf t qid = ignore (t#connect#event ~callback:(triggers_callback t qid env sbuf)) and connect_axiom_tag env t = ignore (t#connect#event ~callback:(axiom_callback t env)) and connect_aterm env sbuf { at_desc = at_desc } = connect_at_desc env sbuf at_desc and connect_aterm_list env sbuf atl = List.iter (connect_aterm env sbuf) atl and connect_aaterm env sbuf connect_tag aat = connect_tag env sbuf aat.tag; connect_aterm env sbuf aat.c and connect_aaterm_list env sbuf connect_tag aatl = List.iter (connect_aaterm env sbuf connect_tag) aatl and connect_at_desc env sbuf = function | ATconst _ | ATvar _ -> () | ATapp (s, atl) -> connect_aterm_list env sbuf atl | ATinfix (t1, _, t2) | ATget (t1, t2) | ATconcat (t1, t2) | ATlet (_, t1, t2) -> connect_aterm env sbuf t1; connect_aterm env sbuf t2 | ATdot (t, _) | ATprefix (_, t) | ATnamed (_, t) -> connect_aterm env sbuf t | ATset (t1,t2,t3) | ATextract (t1,t2,t3) -> connect_aterm env sbuf t1; connect_aterm env sbuf t2; connect_aterm env sbuf t3 | ATrecord r -> let atl = List.map snd r in connect_aterm_list env sbuf atl and connect_aatom env sbuf aa = match aa with | AAtrue | AAfalse -> () | AAeq atl | AAneq atl | AAdistinct atl | AAle atl | AAlt atl | AAbuilt (_, atl) -> connect_aaterm_list env sbuf connect_tag atl | AApred at -> connect_aterm env sbuf at and connect_quant_form env sbuf {aqf_triggers = trs; aqf_form = aaf } = connect_triggers env sbuf trs; connect_aaform env sbuf aaf and connect_triggers env sbuf trs = List.iter (fun (l,_) -> connect_aaterm_list env sbuf connect_tag l) trs and connect_aform env sbuf = function | AFatom a -> connect_aatom env sbuf a | AFop (op, afl) -> connect_aaform_list env sbuf afl | AFforall aqf | AFexists aqf -> connect_trigger_tag env sbuf aqf.tag aqf.id; connect_quant_form env sbuf aqf.c | AFlet (vs, s, t, aaf) -> connect_aterm env sbuf t; connect_aform env sbuf aaf.c | AFnamed (_, aaf) -> connect_aform env sbuf aaf.c and connect_aaform_list env sbuf aafl = List.iter (connect_aaform env sbuf) aafl and connect_aaform env sbuf aaf = connect_tag env sbuf aaf.tag; connect_aform env sbuf aaf.c let connect_atyped_decl env td = match td.c with | APredicate_def (_, _, _, af) | AAxiom (_, _, af) -> connect_axiom_tag env td.tag; connect_aform env env.buffer af | ARewriting (_, _, arwtl) -> connect_tag env env.buffer td.tag (* TODO *) | AGoal (_, _, _, aaf) -> connect_tag env env.buffer td.tag; connect_aform env env.buffer aaf.c | AFunction_def (_, _, _, _, af) -> connect_tag env env.buffer td.tag; connect_aform env env.buffer af | ALogic _ | ATypeDecl _ -> connect_tag env env.buffer td.tag let connect env = List.iter (fun (t, _) -> connect_atyped_decl env t) env.ast let clear_used_lemmas_tags env = MTag.iter (fun t _ -> t#set_property (`BACKGROUND_SET false)) env.proof_tags; List.iter (fun t -> t#set_property (`BACKGROUND_SET false)) env.proof_toptags; env.proof_tags <- MTag.empty; env.proof_toptags <- [] let show_used_lemmas env expl = let colormap = Gdk.Color.get_system_colormap () in let atags,ftags = findtags_proof expl env.ast in clear_used_lemmas_tags env; let max_mul = MTag.fold (fun _ m acc -> max acc m) ftags 0 in let green_0 = Gdk.Color.alloc colormap (`RGB (65535*3/4, 65535, 65535*3/4)) in List.iter (fun t -> t#set_property (`BACKGROUND_GDK green_0)) atags; MTag.iter (fun t m -> let perc = ((max_mul - m) * 65535) / max_mul in let green_n = Gdk.Color.alloc colormap (`RGB (perc*1/2, (perc + 2*65535) /3, perc*1/2)) in t#set_property (`BACKGROUND_GDK green_n)) ftags; env.proof_tags <- ftags; env.proof_toptags <- atags (* More efficient but invariant broken when using user instanciated axioms let prune_unused env expl = let ids = match Explanation.ids_of expl with | None -> [] | Some ids -> List.sort Pervasives.compare ids in let prune_top d = match d.c with | ATypeDecl _ | AGoal _ | ALogic _ -> () | _ -> prune d d.tag in let rec aux dont ast ids = match ast, ids with | [], _ | _, [] -> () | (d, _)::rast, id::rids -> if id = d.id then (* is d *) aux false rast rids else if id < d.id then (* in d *) aux true ast rids else (* not in d *) begin if not dont then prune_top d; aux false rast ids end in aux false env.ast ids *) let prune_unused env = let prune_top d = match d.c with | ATypeDecl _ | AGoal _ | ALogic _ -> () | _ -> prune env d in List.iter (fun (d, _) -> if not (List.mem d.ptag env.proof_toptags) && not (MTag.mem d.ptag env.proof_tags) then prune_top d ) env.ast alt-ergo-1.30/src/gui/gui_replay.mli0000644000175000001440000000323213014515065015731 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Why_annoted open Gui_session val replay_session : env -> unit alt-ergo-1.30/src/gui/why_annoted.ml0000644000175000001440000017053613014515065015753 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Parsed open Typed open Loc open Lexing open Format open Options open Gui_session let indent_size = 4 let max_indent = 80 let monospace_font = Pango.Font.from_string "monospace 13" let general_font = Pango.Font.from_string "sans" let make_indent nb = String.make (min max_indent (nb * indent_size)) ' ' type sbuffer = GSourceView2.source_buffer type error_model = { mutable some : bool; rcols : GTree.column_list; rcol_icon : GtkStock.id GTree.column; rcol_desc : String.t GTree.column; rcol_line : int GTree.column; rcol_type : int GTree.column; rcol_color : String.t GTree.column; rstore : GTree.list_store; } type inst_model = { h : (int, Gtk.tree_iter option ref * int ref * string * int ref) Hashtbl.t; mutable max : int; icols : GTree.column_list; icol_icon : GtkStock.id GTree.column; icol_desc : String.t GTree.column; icol_number : int GTree.column; icol_limit : String.t GTree.column; icol_tag : int GTree.column; istore : GTree.list_store; } type timers_model = { timers : Timers.t; label_sat : GMisc.label; label_match : GMisc.label; label_cc : GMisc.label; label_arith : GMisc.label; label_arrays : GMisc.label; label_sum : GMisc.label; label_records : GMisc.label; label_ac : GMisc.label; tl_sat : GMisc.label; tl_match : GMisc.label; tl_cc : GMisc.label; tl_arith : GMisc.label; tl_arrays : GMisc.label; tl_sum : GMisc.label; tl_records : GMisc.label; tl_ac : GMisc.label; pr_sat : GRange.progress_bar; pr_match : GRange.progress_bar; pr_cc : GRange.progress_bar; pr_arith : GRange.progress_bar; pr_arrays : GRange.progress_bar; pr_sum : GRange.progress_bar; pr_records : GRange.progress_bar; pr_ac : GRange.progress_bar; } type 'a annoted = { mutable c : 'a; mutable pruned : bool; mutable polarity : bool; tag : GText.tag; ptag : GText.tag; id : int; buf : sbuffer; mutable line : int; } type aterm = { at_ty : Ty.t; at_desc : at_desc } and at_desc = | ATconst of tconstant | ATvar of Symbols.t | ATapp of Symbols.t * aterm list | ATinfix of aterm * Symbols.t * aterm | ATprefix of Symbols.t * aterm | ATget of aterm * aterm | ATset of aterm * aterm * aterm | ATextract of aterm * aterm * aterm | ATconcat of aterm * aterm | ATlet of Symbols.t * aterm * aterm | ATdot of aterm * Hstring.t | ATrecord of (Hstring.t * aterm) list | ATnamed of Hstring.t * aterm type aatom = | AAtrue | AAfalse | AAeq of aterm annoted list | AAneq of aterm annoted list | AAdistinct of aterm annoted list | AAle of aterm annoted list | AAlt of aterm annoted list | AApred of aterm | AAbuilt of Hstring.t * aterm annoted list type aoplogic = AOPand |AOPor | AOPimp | AOPnot | AOPif of aterm | AOPiff type aquant_form = { aqf_bvars : (Symbols.t * Ty.t) list ; aqf_upvars : (Symbols.t * Ty.t) list ; mutable aqf_triggers : (aterm annoted list * bool) list ; aqf_form : aform annoted } and aform = | AFatom of aatom | AFop of aoplogic * aform annoted list | AFforall of aquant_form annoted | AFexists of aquant_form annoted | AFlet of (Symbols.t * Ty.t) list * Symbols.t * aterm * aform annoted | AFnamed of Hstring.t * aform annoted type atyped_decl = | AAxiom of Loc.t * string * aform | ARewriting of Loc.t * string * ((aterm rwt_rule) annoted) list | AGoal of Loc.t * goal_sort * string * aform annoted | ALogic of Loc.t * string list * plogic_type | APredicate_def of Loc.t * string * (string * ppure_type) list * aform | AFunction_def of Loc.t * string * (string * ppure_type) list * ppure_type * aform | ATypeDecl of Loc.t * string list * string * body_type_decl type annoted_node = | AD of (atyped_decl annoted * Why_typing.env) | AF of aform annoted * aform annoted option | AT of aterm annoted | QF of aquant_form annoted module MDep = Map.Make ( struct type t = atyped_decl annoted let compare = Pervasives.compare end) module MTag = Map.Make (struct type t = GText.tag let compare t1 t2 = compare t1#get_oid t2#get_oid end) type env = { buffer : sbuffer; goal_view : GSourceView2.source_view; inst_buffer : sbuffer; inst_view : GSourceView2.source_view; errors : error_model; insts : inst_model; st_ctx : GMisc.statusbar_context; mutable ast : (atyped_decl annoted * Why_typing.env) list; mutable ctrl : bool; mutable last_tag : GText.tag; mutable search_tags : GText.tag list; mutable proof_tags : int MTag.t; mutable proof_toptags : GText.tag list; mutable start_select : int option; mutable stop_select : int option; dep : (atyped_decl annoted list * atyped_decl annoted list) MDep.t; actions : action Stack.t; saved_actions : action Stack.t; resulting_ids : (string * int) list; } module HTag = Hashtbl.Make (struct type t = GText.tag let equal t1 t2 = t1#get_oid = t2#get_oid let hash t = t#get_oid end) let increase_size envs = Pango.Font.set_size monospace_font (Pango.Font.get_size monospace_font + 2000); (* eprintf "%d +@." (Pango.Font.get_size monospace_font); *) List.iter (fun env -> env.goal_view#misc#modify_font monospace_font; env.inst_view#misc#modify_font monospace_font; ) envs let decrease_size envs = (* eprintf "%d +@." (Pango.Font.get_size monospace_font); *) Pango.Font.set_size monospace_font (Pango.Font.get_size monospace_font - 2000); List.iter (fun env -> env.goal_view#misc#modify_font monospace_font; env.inst_view#misc#modify_font monospace_font; ) envs let reset_size envs = Pango.Font.set_size monospace_font 13000; List.iter (fun env -> env.goal_view#misc#modify_font monospace_font; env.inst_view#misc#modify_font monospace_font; ) envs let set_font envs font = let f = Pango.Font.from_string font in Pango.Font.set_family monospace_font (Pango.Font.get_family f); Pango.Font.set_size monospace_font (Pango.Font.get_size f); List.iter (fun env -> env.goal_view#misc#modify_font monospace_font; env.inst_view#misc#modify_font monospace_font; ) envs type buffer_pending = { tags_ranges : ((sbuffer * int * int) list) HTag.t; } let pending = { tags_ranges = HTag.create 2001; } let add_tag_range (b, o1, o2) = function | [] -> [b, o1, o2] | (c, p1, p2) :: r when b#get_oid = c#get_oid && o1 <= p2 + 1 -> (c, p1, o2) :: r | l -> (b, o1, o2) :: l let append_buf (buffer:sbuffer) ?iter:(iter=buffer#end_iter) ?tags:(tags=[]) s = let o1 = iter#offset in let o2 = o1 + String.length s in buffer#insert ~iter s; List.iter (fun t -> let bounds = try HTag.find pending.tags_ranges t with Not_found -> [] in HTag.replace pending.tags_ranges t (add_tag_range (buffer, o1, o2) bounds); ) tags let append_mark (buffer:sbuffer) id = ignore(buffer#create_source_mark ~category:(sprintf "trigger_%d" id) buffer#end_iter) let tags_spaces tags = if List.length tags > 40 then tags else [] let commit_tags_buffer (buffer:sbuffer) = HTag.iter (fun t bounds -> List.iter (fun (buf, o1, o2) -> if buf#get_oid = buffer#get_oid then begin let start = buffer#get_iter_at_mark (`MARK (buffer#create_mark (buffer#get_iter (`OFFSET o1)))) in let stop = buffer#get_iter_at_mark (`MARK (buffer#create_mark (buffer#get_iter (`OFFSET o2)))) in buffer#apply_tag t ~start ~stop end ) bounds ) pending.tags_ranges; HTag.clear pending.tags_ranges let create_env buf1 tv1 (buf2:sbuffer) tv2 errors insts st_ctx ast dep actions resulting_ids= let titag = buf2#create_tag [`WEIGHT `BOLD; `UNDERLINE `SINGLE] in buf2#insert ~tags:[titag] "User instantiated axioms:\n\n"; { buffer = buf1; inst_buffer = buf2; goal_view = tv1; inst_view = tv2; errors = errors; insts = insts; st_ctx = st_ctx; ast = ast; dep = dep; ctrl = false; last_tag = GText.tag (); search_tags = []; proof_tags = MTag.empty; proof_toptags = []; start_select = None; stop_select = None; actions = actions; saved_actions = Stack.copy actions; resulting_ids = resulting_ids; } let create_replay_env buf1 errors insts ast actions resulting_ids = { buffer = buf1; inst_buffer = GSourceView2.source_buffer (); goal_view = GSourceView2.source_view (); inst_view = GSourceView2.source_view (); errors = errors; insts = insts; st_ctx = (GMisc.statusbar ())#new_context ~name:""; ast = ast; dep = MDep.empty; ctrl = false; last_tag = GText.tag (); search_tags = []; proof_tags = MTag.empty; proof_toptags = []; start_select = None; stop_select = None; actions = actions; saved_actions = actions; resulting_ids = resulting_ids; } let tag (buffer:sbuffer) = buffer#create_tag [] let new_annot (buffer:sbuffer) c id ptag = { c = c; pruned = false; tag = (tag buffer); ptag = ptag; id = id; polarity = true; buf = buffer; line = buffer#line_count } let rec findin_aterm tag buffer { at_desc = at_desc } = findin_at_desc tag buffer at_desc and findin_aterm_list tag buffer atl = List.fold_left (fun r at -> match r with | None -> findin_aterm tag buffer at | Some _ -> r ) None atl and findin_aaterm tag buffer aat = let goodbuf = aat.buf#get_oid = buffer#get_oid in let c = compare tag#priority aat.tag#priority in if goodbuf && c = 0 then Some (AT aat) else if goodbuf && c > 0 then None else findin_aterm tag buffer aat.c and findin_aaterm_list tag buffer aatl = List.fold_left (fun r aat -> match r with | None -> findin_aaterm tag buffer aat | Some _ -> r ) None aatl and findin_at_desc tag buffer = function | ATconst _ | ATvar _ -> None | ATapp (s, atl) -> findin_aterm_list tag buffer atl | ATinfix (t1, _, t2) | ATget (t1,t2) | ATconcat (t1, t2) | ATlet (_, t1, t2) -> let r = findin_aterm tag buffer t1 in if r == None then findin_aterm tag buffer t2 else r | ATdot (t, _) | ATprefix (_,t) -> findin_aterm tag buffer t | ATset (t1, t2, t3) | ATextract (t1, t2, t3) -> let r = findin_aterm tag buffer t1 in if r == None then let r = findin_aterm tag buffer t2 in if r == None then findin_aterm tag buffer t3 else r else r | ATrecord r -> let atl = List.map snd r in findin_aterm_list tag buffer atl | ATnamed (_, t) -> findin_aterm tag buffer t let findin_aatom tag buffer aa = match aa with | AAtrue | AAfalse -> None | AAeq atl | AAneq atl | AAdistinct atl | AAle atl | AAlt atl | AAbuilt (_, atl) -> findin_aaterm_list tag buffer atl | AApred at -> findin_aterm tag buffer at let rec findin_quant_form tag buffer parent {aqf_triggers = trs; aqf_form = aaf } = let r = findin_triggers tag buffer trs in if r == None then let goodbuf = aaf.buf#get_oid = buffer#get_oid in let c = compare tag#priority aaf.tag#priority in if goodbuf && c = 0 then Some (AF (aaf, parent)) else if goodbuf && c > 0 then None else findin_aform tag buffer (Some aaf) aaf.c else r and findin_triggers tag buffer trs = List.fold_left (fun r (aatl,_) -> match r with | None -> findin_aaterm_list tag buffer aatl | Some _ -> r ) None trs and findin_aform tag buffer parent aform = match aform with | AFatom a -> findin_aatom tag buffer a | AFop (op, afl) -> findin_aaform_list tag buffer parent afl | AFforall qf | AFexists qf -> let goodbuf = qf.buf#get_oid = buffer#get_oid in let c = compare tag#priority qf.tag#priority in if goodbuf && c = 0 then Some (QF qf) else if goodbuf && c > 0 then None else findin_quant_form tag buffer parent qf.c | AFlet (vs, s, t, aaf) -> let r = findin_aterm tag buffer t in if r == None then findin_aaform tag buffer parent aaf else r | AFnamed (_, aaf) -> findin_aform tag buffer parent aaf.c and findin_aaform_list tag buffer parent aafl = List.fold_left (fun r aaf -> match r with | None -> findin_aaform tag buffer parent aaf | Some _ -> r ) None aafl and findin_aaform tag buffer parent aaf = let goodbuf = aaf.buf#get_oid = buffer#get_oid in let c = compare tag#priority aaf.tag#priority in if goodbuf && c = 0 then Some (AF (aaf, parent)) else if goodbuf && c > 0 then None else findin_aform tag buffer (Some aaf) aaf.c let findin_atyped_delc tag buffer (td, env) stop_decl = let goodbuf = td.buf#get_oid = buffer#get_oid in let c = compare tag#priority td.tag#priority in if goodbuf && c = 0 then Some (AD (td, env)) else if goodbuf && c > 0 then None else if stop_decl then Some (AD (td, env)) else match td.c with | AAxiom (_, _, af) | APredicate_def (_, _, _, af) | AFunction_def (_, _, _, _, af) -> let aaf = new_annot buffer af (-1) tag in (* TODO: Change this so af is annoted *) findin_aform tag buffer (Some aaf) af | ARewriting (_, _, rwtl) -> None (*List.fold_left (fun {rwt_left = rl; rwt_right = rr} acc -> match acc with | Some _ -> acc | None -> findin_aterm_list tag buffer [rl; rr] ) rwtl None*) | AGoal (_, _, _, aaf) -> let goodbuf = aaf.buf#get_oid = buffer#get_oid in let c = compare tag#priority aaf.tag#priority in if goodbuf && c = 0 then Some (AF (aaf, None)) else if goodbuf && c > 0 then None else findin_aform tag buffer (Some aaf) aaf.c | ALogic _ | ATypeDecl _ -> None let find_aux stop_decl tag buffer l = List.fold_left (fun r td -> match r with | None -> findin_atyped_delc tag buffer td stop_decl | Some _ -> r ) None l let find = find_aux false let find_decl = find_aux true let rec print_ppure_type fmt = function | PPTunit -> fprintf fmt "unit" | PPTint -> fprintf fmt "int" | PPTbool -> fprintf fmt "bool" | PPTreal -> fprintf fmt "real" | PPTbitv size -> fprintf fmt "bitv[%d]" size | PPTvarid (s, loc) -> fprintf fmt "\'%s" s (* | PPTfarray pp -> fprintf fmt "%a farray" print_ppure_type pp *) | PPTexternal ([], s, loc) -> fprintf fmt "%s" s | PPTexternal (pptypes, s, loc) -> fprintf fmt "%a %s" (print_ppure_type_list true) pptypes s and print_ppure_type_list nested fmt l = let rec aux fmt = function | [] -> () | [p] -> print_ppure_type fmt p | p::r -> fprintf fmt "%a,%a" print_ppure_type p aux r in if not nested then aux fmt l else match l with | [] -> () | [s] -> aux fmt l | s::r -> fprintf fmt "(%a)" aux l let print_plogic_type fmt = function | PPredicate [] -> fprintf fmt "prop" | PPredicate pptl -> fprintf fmt "%a -> prop" (print_ppure_type_list false) pptl | PFunction ([], ppt) -> fprintf fmt "%a" print_ppure_type ppt | PFunction (pptl, ppt) -> fprintf fmt "%a -> %a" (print_ppure_type_list false) pptl print_ppure_type ppt let print_tconstant fmt = function | Tvoid -> fprintf fmt "void" | Ttrue -> fprintf fmt "true" | Tfalse -> fprintf fmt "false" | Tint s -> fprintf fmt "%s" s | Treal n -> fprintf fmt "%s" (Num.string_of_num n) | Tbitv s -> fprintf fmt "%s" s let tconstant_to_string = function | Tvoid -> "void" | Ttrue -> "true" | Tfalse -> "false" | Tint s -> s | Treal n -> Num.string_of_num n | Tbitv s -> s let rec print_var_list fmt = function | [] -> () | [s,ty] -> fprintf fmt "%a:%a" Symbols.print_clean s Ty.print ty | (s,ty)::l -> fprintf fmt "%a:%a,%a" Symbols.print_clean s Ty.print ty print_var_list l let rec print_string_sep sep fmt = function | [] -> () | [s] -> fprintf fmt "%s" s | s::r -> fprintf fmt "%s%s%a" s sep (print_string_sep sep) r let rec print_string_list fmt = print_string_sep "," fmt let print_astring_list fmt l = let rec aux fmt = function | [] -> () | [s] -> fprintf fmt "\'%s" s | s::r -> fprintf fmt "\'%s,%a" s aux r in match l with | [] -> () | [s] -> aux fmt l | s::r -> fprintf fmt "(%a)" aux l let rec print_string_ppure_type_list fmt = function | [] -> () | [s,ppt] -> fprintf fmt "%s:%a" s print_ppure_type ppt | (s,ppt)::l -> fprintf fmt "%s:%a,%a" s print_ppure_type ppt print_string_ppure_type_list l let print_pred_type_list fmt = function | [] -> () | l -> fprintf fmt "(%a)" print_string_ppure_type_list l (**************** to delete *******************) let rec print_tterm fmt {Typed.c= {tt_desc = tt_desc}} = print_tt_desc fmt tt_desc and print_tterm_list se fmt = function | [] -> () | [t] -> print_tterm fmt t | t::r -> fprintf fmt "%a%s%a" print_tterm t se (print_tterm_list se) r and print_record se fmt = function | [] -> () | [c,t] -> fprintf fmt "%s = %a" (Hstring.view c) print_tterm t | (c,t)::r -> fprintf fmt "%s = %a%s%a" (Hstring.view c) print_tterm t se (print_record se) r and print_tt_desc fmt = function | TTconst c -> print_tconstant fmt c | TTvar s -> Symbols.print_clean fmt s | TTapp (f, ts) -> fprintf fmt "%a(%a)" Symbols.print_clean f (print_tterm_list ",") ts | TTinfix (t1, s, t2) -> fprintf fmt "%a %a %a" print_tterm t1 Symbols.print_clean s print_tterm t2 | TTprefix (s, t) -> fprintf fmt "%a %a" Symbols.print_clean s print_tterm t | TTlet (s, t1, t2) -> fprintf fmt "let %a = %a in %a" Symbols.print_clean s print_tterm t1 print_tterm t2 | TTconcat (t1, t2) -> fprintf fmt "%a@%a" print_tterm t1 print_tterm t2 | TTextract (t, t1, t2) -> fprintf fmt "%a^{%a;%a}" print_tterm t print_tterm t1 print_tterm t2 | TTset (t, t1, t2) -> fprintf fmt "%a[%a<-%a]" print_tterm t print_tterm t1 print_tterm t2 | TTget (t, t1) -> fprintf fmt "%a[%a]" print_tterm t print_tterm t1 | TTdot (t, c) -> fprintf fmt "%a.%s" print_tterm t (Hstring.view c) | TTrecord r -> fprintf fmt "{ %a }" (print_record ";") r | TTnamed (lbl, t) -> fprintf fmt "%s:%a" (Hstring.view lbl) print_tterm t let print_tatom fmt a = match a.Typed.c with | TAtrue -> fprintf fmt "true" | TAfalse -> fprintf fmt "false" | TAeq tl -> print_tterm_list " = " fmt tl | TAneq tl -> print_tterm_list " <> " fmt tl | TAdistinct tl -> fprintf fmt "distinct(%a)" (print_tterm_list ",") tl | TAle tl -> print_tterm_list " <= " fmt tl | TAlt tl -> print_tterm_list " < " fmt tl | TApred t -> print_tterm fmt t | TAbuilt (h, tl) -> print_tterm_list (" "^(Hstring.view h)^" ") fmt tl let print_oplogic fmt = function | OPand -> fprintf fmt "and" | OPor -> fprintf fmt "or" | OPimp -> fprintf fmt "->" | OPnot -> fprintf fmt "not" | OPif t -> fprintf fmt "%a ->" print_tterm t | OPiff -> fprintf fmt "<->" let print_rwt fmt { rwt_vars = rv; rwt_left = rl; rwt_right = rr } = fprintf fmt "forall %a. %a = %a" print_var_list rv print_tterm rl print_tterm rr let rec print_rwt_list fmt = function | [] -> () | [rwt] -> print_rwt fmt rwt | rwt::l -> fprintf fmt "%a; %a" print_rwt rwt print_rwt_list l let rec print_quant_form fmt {qf_bvars = bv; qf_upvars = uv; qf_triggers = trs; qf_form = tf } = fprintf fmt "%a [%a]. %a" print_var_list bv print_triggers trs print_tform tf and print_triggers fmt = function | [] -> () | [ts,_] -> print_tterm_list "," fmt ts | (ts,_)::l -> fprintf fmt "%a | %a" (print_tterm_list ",") ts print_triggers l and print_tform2 fmt f = match f.Typed.c with | TFatom a -> print_tatom fmt a | TFop (OPnot, [tf]) -> fprintf fmt "not %a" print_tform tf | TFop (op, tfl) -> print_tform_list op fmt tfl | TFforall qf -> fprintf fmt "forall %a" print_quant_form qf | TFexists qf -> fprintf fmt "exists %a" print_quant_form qf | TFlet (vs, s, t, tf) -> fprintf fmt "let %a = %a in\n %a" Symbols.print_clean s print_tterm t print_tform tf | TFnamed (_, tf) -> print_tform fmt tf and print_tform fmt f = fprintf fmt " (id:%d)%a" f.Typed.annot print_tform2 f and print_tform_list op fmt = function | [] -> () | [tf] -> print_tform fmt tf | tf::l -> fprintf fmt "%a %a %a" print_tform tf print_oplogic op (print_tform_list op) l let rec print_record_type fmt = function | [] -> () | [c, ty] -> fprintf fmt "%s : %a" c print_ppure_type ty | (c, ty)::l -> fprintf fmt "%s : %a; %a" c print_ppure_type ty print_record_type l let print_typed_decl fmt td = match td.Typed.c with | TAxiom (_, s, tf) -> fprintf fmt "axiom %s : %a" s print_tform tf | TRewriting (_, s, rwtl) -> fprintf fmt "rewriting %s : %a" s print_rwt_list rwtl | TGoal (_, Thm, s, tf) -> fprintf fmt "goal %s : %a" s print_tform tf | TGoal (_, Check, s, tf) -> fprintf fmt "check %s : %a" s print_tform tf | TGoal (_, Cut, s, tf) -> fprintf fmt "cut %s : %a" s print_tform tf | TLogic (_, ls, ty) -> fprintf fmt "logic %a : %a" print_string_list ls print_plogic_type ty | TPredicate_def (_, p, spptl, tf) -> fprintf fmt "predicate %s %a = %a" p print_pred_type_list spptl print_tform tf | TFunction_def (_, f, spptl, ty, tf) -> fprintf fmt "function %s (%a) : %a = %a" f print_string_ppure_type_list spptl print_ppure_type ty print_tform tf | TTypeDecl (_, ls, s, Abstract) -> fprintf fmt "type %a %s" print_astring_list ls s | TTypeDecl (_, ls, s, Enum lc) -> fprintf fmt "type %a %s = %a" print_astring_list ls s (print_string_sep " | ") lc | TTypeDecl (_, ls, s, Record rt) -> fprintf fmt "type %a %s = %a" print_astring_list ls s print_record_type rt let print_typed_decl_list fmt = List.iter (fprintf fmt "%a@." print_typed_decl) (**********************************************) (****************** Computing dependancies ***********************) let find_dep_by_string dep s = MDep.fold (fun d _ found -> match found with | Some _ -> found | None -> begin match d.c with | ALogic (_, ls, ty) when List.mem s ls -> Some d | ATypeDecl (_, _, s', _) when Pervasives.(=) s s'-> Some d | APredicate_def (_, p, _, _) when Pervasives.(=) s p -> Some d | AFunction_def (_, f, _, _, _) when Pervasives.(=) s f -> Some d | _ -> None end ) dep None let find_tag_deps dep tag = MDep.fold (fun d (deps,_) found -> match found with | Some _ -> found | None -> if Pervasives.(=) d.tag tag then Some deps else None ) dep None let find_tag_inversedeps dep tag = MDep.fold (fun d (_,deps) found -> match found with | Some _ -> found | None -> if Pervasives.(=) d.tag tag then Some deps else None ) dep None let make_dep_string d ex dep s = if not (List.mem s ex) then let m = find_dep_by_string dep s in match m with | None -> dep | Some d' -> let deps, depsi = try MDep.find d' dep with Not_found -> [], [] in let dep = MDep.add d' (deps, d::depsi) dep in let deps, depsi = try MDep.find d dep with Not_found -> [], [] in MDep.add d (d'::deps, depsi) dep else dep let rec make_dep_aterm d ex dep {at_desc = at_desc; at_ty = at_ty } = make_dep_at_desc d ex dep at_desc and make_dep_aaterm d ex dep aat = make_dep_aterm d ex dep aat.c and make_dep_at_desc d ex dep = function | ATconst _ -> dep | ATvar s -> make_dep_string d ex dep (Symbols.to_string_clean s) | ATapp (s, atl) -> let dep = make_dep_string d ex dep (Symbols.to_string_clean s) in List.fold_left (make_dep_aterm d ex) dep atl | ATinfix (t1, s, t2) -> let dep = make_dep_aterm d ex dep t1 in let dep = make_dep_string d ex dep (Symbols.to_string_clean s) in make_dep_aterm d ex dep t2 | ATprefix (s, t) -> let dep = make_dep_string d ex dep (Symbols.to_string_clean s) in make_dep_aterm d ex dep t | ATget (t1, t2) | ATconcat (t1, t2) -> let dep = make_dep_aterm d ex dep t1 in make_dep_aterm d ex dep t2 | ATset (t1, t2, t3) | ATextract (t1, t2, t3) -> let dep = make_dep_aterm d ex dep t1 in let dep = make_dep_aterm d ex dep t2 in make_dep_aterm d ex dep t3 | ATlet (s, t1, t2) -> let dep = make_dep_string d ex dep (Symbols.to_string_clean s) in let dep = make_dep_aterm d ex dep t1 in make_dep_aterm d ex dep t2 | ATdot (t, c) -> let dep = make_dep_string d ex dep (Hstring.view c) in make_dep_aterm d ex dep t | ATrecord r -> List.fold_left (fun dep (c, t) -> let dep = make_dep_string d ex dep (Hstring.view c) in make_dep_aterm d ex dep t) dep r | ATnamed (_, t) -> make_dep_aterm d ex dep t let make_dep_aatom d ex dep = function | AAtrue | AAfalse -> dep | AAeq atl | AAneq atl | AAdistinct atl | AAle atl | AAlt atl -> List.fold_left (make_dep_aaterm d ex) dep atl | AApred at -> make_dep_aterm d ex dep at | AAbuilt (h, atl) -> List.fold_left (make_dep_aaterm d ex) dep atl let make_dep_oplogic d ex dep = function | AOPif at -> make_dep_aterm d ex dep at | _ -> dep let rec make_dep_quant_form d ex dep {aqf_bvars = bv; aqf_upvars = uv; aqf_triggers = trs; aqf_form = aaf } = let vars = List.map (fun (s,_) -> (Symbols.to_string_clean s)) bv in make_dep_aform d (vars@ex) dep aaf.c and make_dep_aform d ex dep = function | AFatom a -> make_dep_aatom d ex dep a | AFop (op, afl) -> List.fold_left (make_dep_aaform d ex) dep afl | AFforall qf -> make_dep_quant_form d ex dep qf.c | AFexists qf -> make_dep_quant_form d ex dep qf.c | AFlet (vs, s, t, aaf) -> let dep = make_dep_aterm d ex dep t in make_dep_aaform d ex dep aaf | AFnamed (_, aaf) -> make_dep_aform d ex dep aaf.c and make_dep_aaform d ex dep aaf = make_dep_aform d ex dep aaf.c let make_dep_atyped_decl dep d = match d.c with | AAxiom (loc, s, af) -> make_dep_aform d [] dep af | ARewriting (loc, s, arwtl) -> List.fold_left (fun dep r -> let vars = List.map (fun (s,_) -> (Symbols.to_string_clean s)) r.c.rwt_vars in let dep = make_dep_aterm d vars dep r.c.rwt_left in make_dep_aterm d vars dep r.c.rwt_right ) dep arwtl | AGoal (loc, _, s, aaf) -> make_dep_aform d [] dep aaf.c | ALogic (loc, ls, ty) -> MDep.add d ([], []) dep | APredicate_def (loc, p, spptl, af) -> let dep = MDep.add d ([], []) dep in make_dep_aform d (p::(List.map fst spptl)) dep af | AFunction_def (loc, f, spptl, ty, af) -> let dep = MDep.add d ([], []) dep in make_dep_aform d (f::(List.map fst spptl)) dep af | ATypeDecl (loc, ls, s, lc) -> MDep.add d ([], []) dep let make_dep annoted_ast = let dep = MDep.empty in List.fold_left (fun dep (t,_) -> make_dep_atyped_decl dep t) dep annoted_ast (* Translation from AST to annoted/pruned AST *) let annot_of_tconstant (buffer:sbuffer) t = new_annot buffer t let rec of_tterm (buffer:sbuffer) t = {at_desc = of_tt_desc buffer t.Typed.c.tt_desc; at_ty = t.Typed.c.tt_ty } and annot_of_tterm (buffer:sbuffer) t = let ptag = tag buffer in let c = of_tterm buffer t in new_annot buffer c t.Typed.annot ptag and of_tt_desc (buffer:sbuffer) = function | TTconst c -> (ATconst c) | TTvar s ->(ATvar s) | TTapp (s, tts) -> ATapp (s, List.map (of_tterm buffer ) tts) | TTinfix (t1, s, t2) -> ATinfix (of_tterm buffer t1, s, of_tterm buffer t2) | TTprefix (s,t) -> ATprefix (s, of_tterm buffer t) | TTget (t1, t2) -> ATget (of_tterm buffer t1, of_tterm buffer t2) | TTset (t, t1, t2) -> ATset (of_tterm buffer t, of_tterm buffer t1, of_tterm buffer t2) | TTextract (t, t1, t2) -> ATextract (of_tterm buffer t, of_tterm buffer t1, of_tterm buffer t2) | TTconcat (t1, t2) -> ATconcat (of_tterm buffer t1, of_tterm buffer t2) | TTlet (s, t1, t2) -> ATlet (s, of_tterm buffer t1, of_tterm buffer t2) | TTdot (t, c) -> ATdot (of_tterm buffer t, c) | TTrecord r -> ATrecord (List.map (fun (c,t) -> (c, of_tterm buffer t)) r) | TTnamed (lbl, t) -> ATnamed (lbl, of_tterm buffer t) let of_tatom (buffer:sbuffer) a = match a.Typed.c with | TAtrue -> AAtrue | TAfalse -> AAfalse | TAeq tl -> AAeq (List.map (annot_of_tterm buffer ) tl) | TAneq tl -> AAneq (List.map (annot_of_tterm buffer ) tl) | TAdistinct tl -> AAdistinct (List.map (annot_of_tterm buffer ) tl) | TAle tl -> AAle (List.map (annot_of_tterm buffer ) tl) | TAlt tl -> AAlt (List.map (annot_of_tterm buffer ) tl) | TApred t -> AApred (of_tterm buffer t) | TAbuilt (h, tl) -> AAbuilt (h, (List.map (annot_of_tterm buffer ) tl)) let of_oplogic (buffer:sbuffer) = function | OPand -> AOPand | OPor -> AOPor | OPimp -> AOPimp | OPnot -> AOPnot | OPif t -> AOPif (of_tterm buffer t) | OPiff -> AOPiff let rec change_polarity_aform f = f.polarity <- not f.polarity; match f.c with | AFatom _ -> () | AFop (_, afl) -> List.iter change_polarity_aform afl | AFforall aaqf | AFexists aaqf -> aaqf.polarity <- not aaqf.polarity; change_polarity_aform aaqf.c.aqf_form | AFlet (_,_,_,af) | AFnamed (_, af) -> change_polarity_aform af let rec of_quant_form (buffer:sbuffer) {qf_bvars = bv; qf_upvars = uv; qf_triggers = trs; qf_form = tf } = let ptag = tag buffer in { aqf_bvars = bv; aqf_upvars = uv; aqf_triggers = List.map (fun (l,b) -> List.map (annot_of_tterm buffer) l, b) trs; aqf_form = new_annot buffer (of_tform buffer tf) tf.Typed.annot ptag} and annot_of_quant_form (buffer:sbuffer) qf id = let ptag = tag buffer in new_annot buffer (of_quant_form buffer qf) id ptag and of_tform (buffer:sbuffer) f = match f.Typed.c with | TFatom a -> AFatom (of_tatom buffer a) | TFop (op, tfl) -> let afl = List.map (annot_of_tform buffer ) tfl in assert (let l = List.length afl in l >= 1 && l <= 2); if op == OPnot || op == OPimp then change_polarity_aform (List.hd afl); AFop (of_oplogic buffer op, afl) | TFforall qf -> AFforall (annot_of_quant_form buffer qf f.Typed.annot) | TFexists qf -> AFexists (annot_of_quant_form buffer qf f.Typed.annot) | TFlet (vs, s, t, tf) -> AFlet (vs, s, of_tterm buffer t, annot_of_tform buffer tf) | TFnamed (n, tf) -> AFnamed (n, annot_of_tform buffer tf) and annot_of_tform (buffer:sbuffer) t = let ptag = tag buffer in let c = of_tform buffer t in new_annot buffer c t.Typed.annot ptag let annot_of_typed_decl (buffer:sbuffer) td = let ptag = tag buffer in let c = match td.Typed.c with | TAxiom (loc, s, tf) -> AAxiom (loc, s, of_tform buffer tf) | TRewriting (loc, s, rwtl) -> let arwtl = List.map (fun rwt -> new_annot buffer { rwt with rwt_left = of_tterm buffer rwt.rwt_left; rwt_right = of_tterm buffer rwt.rwt_right } td.Typed.annot ptag ) rwtl in ARewriting (loc, s, arwtl) | TGoal (loc, gs, s, tf) -> let g = new_annot buffer (of_tform buffer tf) tf.Typed.annot ptag in AGoal (loc, gs, s, g) | TLogic (loc, ls, ty) -> ALogic (loc, ls, ty) | TPredicate_def (loc, p, spptl, tf) -> APredicate_def (loc, p, spptl, of_tform buffer tf) | TFunction_def (loc, f, spptl, ty, tf) -> AFunction_def (loc, f, spptl, ty, of_tform buffer tf) | TTypeDecl (loc, ls, s, lc) -> ATypeDecl (loc, ls, s, lc) in new_annot buffer c td.Typed.annot ptag let annot (buffer:sbuffer) ast = List.map (fun (t,env) -> (annot_of_typed_decl buffer t, env)) ast (* Translation from annoted/pruned AST to AST *) let rec to_tterm id {at_desc = at_desc; at_ty = at_ty } = {Typed.c = { tt_desc = to_tt_desc at_desc; tt_ty = at_ty }; Typed.annot = id } and from_aaterm_list = function | [] -> [] | at::l -> if at.pruned then from_aaterm_list l else (to_tterm at.id at.c)::(from_aaterm_list l) and to_tt_desc = function | ATconst c -> TTconst c | ATvar s -> TTvar s | ATapp (s, atl) -> TTapp (s, List.map (to_tterm 0) atl) | ATinfix (t1, s, t2) -> TTinfix (to_tterm 0 t1, s, to_tterm 0 t2) | ATprefix (s, t) -> TTprefix (s, to_tterm 0 t) | ATget (t1, t2) -> TTget (to_tterm 0 t1, to_tterm 0 t2) | ATset (t1, t2, t3) -> TTset (to_tterm 0 t1, to_tterm 0 t2, to_tterm 0 t3) | ATextract (t1, t2, t3) -> TTextract (to_tterm 0 t1, to_tterm 0 t2, to_tterm 0 t3) | ATconcat (t1, t2) -> TTconcat (to_tterm 0 t1, to_tterm 0 t2) | ATlet (s, t1, t2) -> TTlet (s, to_tterm 0 t1, to_tterm 0 t2) | ATdot (t, c) -> TTdot (to_tterm 0 t, c) | ATrecord r -> TTrecord (List.map (fun (c, t) -> (c, to_tterm 0 t)) r) | ATnamed (lbl, t) -> TTnamed (lbl, to_tterm 0 t) let to_tatom aa id = let c = match aa with | AAtrue -> TAtrue | AAfalse -> TAfalse | AAeq atl -> TAeq (from_aaterm_list atl) | AAneq atl -> TAneq (from_aaterm_list atl) | AAdistinct atl -> TAdistinct (from_aaterm_list atl) | AAle atl -> TAle (from_aaterm_list atl) | AAlt atl -> TAlt (from_aaterm_list atl) | AApred at -> TApred (to_tterm 0 at) | AAbuilt (h, atl) -> TAbuilt (h, (from_aaterm_list atl)) in { Typed.c = c; Typed.annot = id } let to_oplogic = function | AOPand -> OPand | AOPor -> OPor | AOPimp -> OPimp | AOPnot -> OPnot | AOPif at -> OPif (to_tterm 0 at) | AOPiff -> OPiff let rec to_quant_form {aqf_bvars = bv; aqf_upvars = uv; aqf_triggers = trs; aqf_form = aaf } = { qf_bvars = bv; qf_upvars = uv; qf_triggers = to_triggers trs; qf_form = to_tform aaf } and to_triggers = function | [] -> [] | (atl,b)::l -> let l' = from_aaterm_list atl in if l' == [] then to_triggers l else (l', b)::(to_triggers l) and void_to_tform af id = let c = match af with | AFatom a -> TFatom (to_tatom a id) | AFop (op, afl) -> let tfl = from_aaform_list afl in let op = to_oplogic op in begin match tfl, op with | [], _ -> failwith "Empty logic operation" | [tf], OPnot -> TFop (op, tfl) | [tf], _ -> tf.Typed.c | _ -> TFop (op, tfl) end | AFforall qf -> TFforall (to_quant_form qf.c) | AFexists qf -> TFexists (to_quant_form qf.c) | AFlet (vs, s, t, aaf) -> TFlet (vs, s, to_tterm 0 t, to_tform aaf) | AFnamed (n, aaf) -> TFnamed (n, to_tform aaf) in { Typed.c = c; Typed.annot = id } and to_tform aaf = void_to_tform aaf.c aaf.id and from_aaform_list = function | [] -> [] | aaf::l -> if aaf.pruned then from_aaform_list l else let l = from_aaform_list l in try (to_tform aaf)::l with Failure s -> assert (String.compare s "Empty logic operation" = 0); l let to_typed_decl td = let c = match td.c with | AAxiom (loc, s, af) -> let af = void_to_tform af td.id in TAxiom (loc, s, af) | ARewriting (loc, s, arwtl) -> let rwtl = List.fold_left (fun rwtl ar -> if ar.pruned then rwtl else { rwt_vars = ar.c.rwt_vars; rwt_left = to_tterm ar.id ar.c.rwt_left; rwt_right = to_tterm ar.id ar.c.rwt_right}::rwtl ) [] arwtl in TRewriting (loc, s, rwtl) | AGoal (loc, gs, s, aaf) -> TGoal (loc, gs, s, to_tform aaf) | ALogic (loc, ls, ty) -> TLogic (loc, ls, ty) | APredicate_def (loc, p, spptl, af) -> TPredicate_def (loc, p, spptl, void_to_tform af td.id) | AFunction_def (loc, f, spptl, ty, af) -> TFunction_def (loc, f, spptl, ty, void_to_tform af td.id) | ATypeDecl (loc, ls, s, lc) -> TTypeDecl (loc, ls, s, lc) in { Typed.c = c; Typed.annot = td.id } let rec to_ast = function | [] -> [] | (atd, _)::l -> if atd.pruned then to_ast l else (to_typed_decl atd)::(to_ast l) let rec add_aterm_at (buffer:sbuffer) tags iter {at_desc = at_desc; at_ty = at_ty } = add_at_desc_at buffer tags iter at_desc and add_aterm (buffer:sbuffer) tags tt = add_aterm_at buffer tags buffer#end_iter tt and add_aterm_list_at (buffer:sbuffer) tags iter sep = function | [] -> () | [at] -> add_aterm_at buffer tags iter at; | at::l -> add_aterm_at buffer tags iter at; append_buf buffer ~iter ~tags sep; add_aterm_list_at buffer tags iter sep l and add_aaterm_at (buffer:sbuffer) tags iter at = at.line <- iter#line; add_aterm_at buffer (at.tag::at.ptag::tags) iter at.c and add_aaterm (buffer:sbuffer) tags at = at.line <- buffer#line_count; add_aaterm_at buffer tags buffer#end_iter at and add_aaterm_list_at (buffer:sbuffer) tags iter sep = function | [] -> () | [at] -> add_aaterm_at buffer tags iter at; | at::l -> add_aaterm_at buffer tags iter at; append_buf buffer ~iter ~tags sep; add_aaterm_list_at buffer tags iter sep l and add_aaterm_list (buffer:sbuffer) tags sep atl = add_aaterm_list_at buffer tags buffer#end_iter sep atl and add_arecord_at (buffer:sbuffer) tags iter = function | [] -> () | [c, at] -> append_buf buffer ~iter ~tags (sprintf "%s = " (Hstring.view c)); add_aterm_at buffer tags iter at; | (c, at)::l -> append_buf buffer ~iter ~tags (sprintf "%s = " (Hstring.view c)); add_aterm_at buffer tags iter at; append_buf buffer ~iter ~tags "; "; add_arecord_at buffer tags iter l and add_at_desc_at (buffer:sbuffer) tags iter at = (* let off1 = iter#offset in *) (* let off = off1 - (buffer#get_iter (`OFFSET off1))#line_offset in *) (* print_endline (sprintf "%d" off); *) (* let iter = buffer#get_iter (`OFFSET off1) in *) match at with | ATconst c -> append_buf buffer ~iter ~tags (sprintf "%s" (tconstant_to_string c)) | ATvar s -> append_buf buffer ~iter ~tags (sprintf "%s" (Symbols.to_string_clean s)) | ATapp (s, atl) -> append_buf buffer ~iter ~tags (sprintf "%s(" (Symbols.to_string_clean s)); add_aterm_list_at buffer tags iter "," atl; append_buf buffer ~iter ~tags ")" | ATinfix (t1, s, t2) -> add_aterm_at buffer tags iter t1; append_buf buffer ~iter ~tags (sprintf " %s " (Symbols.to_string_clean s)); add_aterm_at buffer tags iter t2 | ATprefix (s, t) -> append_buf buffer ~iter ~tags (sprintf " %s " (Symbols.to_string_clean s)); add_aterm_at buffer tags iter t | ATget (t1, t2) -> add_aterm_at buffer tags iter t1; append_buf buffer ~iter ~tags "["; add_aterm_at buffer tags iter t2; append_buf buffer ~iter ~tags "]" | ATset (t1, t2, t3) -> add_aterm_at buffer tags iter t1; append_buf buffer ~iter ~tags "["; add_aterm_at buffer tags iter t2; append_buf buffer ~iter ~tags "<-"; add_aterm_at buffer tags iter t3; append_buf buffer ~iter ~tags "]" | ATextract (t1, t2, t3) -> add_aterm_at buffer tags iter t1; append_buf buffer ~iter ~tags "^{"; add_aterm_at buffer tags iter t2; append_buf buffer ~iter ~tags ","; add_aterm_at buffer tags iter t3; append_buf buffer ~iter ~tags "}" | ATconcat (t1, t2) -> add_aterm_at buffer tags iter t1; append_buf buffer ~iter ~tags "@"; add_aterm_at buffer tags iter t2 | ATlet (s, t1, t2) -> append_buf buffer ~iter ~tags (sprintf "let %s = " (Symbols.to_string_clean s)); add_aterm_at buffer tags iter t1; append_buf buffer ~iter ~tags " in "; add_aterm_at buffer tags iter t2 | ATdot (t, c) -> add_aterm_at buffer tags iter t; append_buf buffer ~iter ~tags (sprintf ".%s" (Hstring.view c)) | ATrecord r -> append_buf buffer ~iter ~tags "{ "; add_arecord_at buffer tags iter r; append_buf buffer ~iter ~tags " }" | ATnamed (n, t) -> append_buf buffer ~iter ~tags (sprintf "%s: " (Hstring.view n)); add_aterm_at buffer tags iter t let add_aatom (buffer:sbuffer) indent tags aa = append_buf buffer (make_indent indent); match aa with | AAtrue -> append_buf buffer ~tags "true" | AAfalse -> append_buf buffer ~tags "false" | AAeq atl -> add_aaterm_list buffer tags " = " atl | AAneq atl -> add_aaterm_list buffer tags " <> " atl | AAdistinct atl -> append_buf buffer ~tags "distinct("; add_aaterm_list buffer tags "," atl; append_buf buffer ~tags ")" | AAle atl -> add_aaterm_list buffer tags " <= " atl | AAlt atl -> add_aaterm_list buffer tags " < " atl | AApred at -> add_aterm buffer tags at | AAbuilt (h, atl) -> add_aaterm_list buffer tags (" "^(Hstring.view h)^" ") atl let add_oplogic (buffer:sbuffer) indent tags op = match op with | AOPand -> append_buf buffer ~tags "and " | AOPor -> append_buf buffer ~tags "or " | AOPimp -> append_buf buffer ~tags "-> " | AOPnot -> append_buf buffer ~tags "not " | AOPif at -> append_buf buffer (String.make indent ' '); append_buf buffer ~tags "if "; add_aterm buffer tags at; append_buf buffer ~tags " then " | AOPiff -> append_buf buffer ~tags "<-> " let add_rwt (buffer:sbuffer) indent tags r = let { rwt_vars = rv; rwt_left = rl; rwt_right = rr } = r.c in let tags = r.tag::r.ptag::tags in append_buf buffer (make_indent indent); append_buf buffer ~tags "forall "; fprintf str_formatter "%a. " print_var_list rv; append_buf buffer ~tags (flush_str_formatter ()); add_aterm buffer tags rl; append_buf buffer ~tags " = "; add_aterm buffer tags rr let rec add_rwt_list (buffer:sbuffer) indent tags = function | [] -> () | [r] -> add_rwt buffer indent tags r | r::l -> add_rwt buffer indent tags r; append_buf buffer ~tags ";"; append_buf buffer "\n"; add_rwt_list buffer indent tags l let add_empty_triggers_error ({rstore = rstore} as errors) (buffer:sbuffer) = let row = rstore#append () in rstore#set ~row ~column:errors.rcol_icon `DIALOG_WARNING; rstore#set ~row ~column:errors.rcol_desc "Warning : Empty trigger, this lemma won't be instantiated."; rstore#set ~row ~column:errors.rcol_color "red"; rstore#set ~row ~column:errors.rcol_type 1; rstore#set ~row ~column:errors.rcol_line buffer#line_count; errors.some <- true let rec add_quant_form errors (buffer:sbuffer) indent tags qf = let {aqf_bvars = bv; aqf_upvars = uv; aqf_triggers = trs; aqf_form = aaf } = qf.c in fprintf str_formatter "%a " print_var_list bv; append_buf buffer ~tags (flush_str_formatter ()); let ntags = qf.tag::qf.ptag::tags in append_buf buffer ~tags:ntags "["; add_triggers errors buffer ntags trs; append_buf buffer ~tags:ntags "]."; append_mark buffer qf.id; append_buf buffer ~tags:(tags_spaces tags) "\n"; append_buf buffer ~tags:(tags_spaces tags) (make_indent (indent + 1)); add_aaform errors buffer (indent+1) tags aaf and add_triggers errors (buffer:sbuffer) tags triggers = let rec add_triggers_aux = function | [] -> () | [atl, b] -> add_aaterm_list buffer tags "," atl | (atl, b)::l -> add_aaterm_list buffer tags "," atl; append_buf buffer ~tags " | "; add_triggers_aux l in if triggers == [] then add_empty_triggers_error errors buffer else add_triggers_aux triggers and add_aform errors (buffer:sbuffer) indent tags aform = match aform with | AFatom a -> add_aatom buffer 0 tags a | AFop (op, afl) -> add_aaform_list errors buffer indent tags op afl | AFforall qf -> append_buf buffer ~tags "forall "; add_quant_form errors buffer indent tags qf | AFexists qf -> append_buf buffer ~tags "exists "; add_quant_form errors buffer indent tags qf | AFlet (vs, s, t, aaf) -> append_buf buffer ~tags (sprintf "let %s = " (Symbols.to_string_clean s)); add_aterm buffer tags t; append_buf buffer ~tags " in"; append_buf buffer ~tags:(tags_spaces tags) "\n"; append_buf buffer ~tags:(tags_spaces tags) (make_indent indent); add_aaform errors buffer (indent) tags aaf | AFnamed (n, aaf) -> append_buf buffer ~tags (sprintf "%s: " (Hstring.view n)); add_aform errors buffer indent tags aaf.c and add_aaform_list errors (buffer:sbuffer) indent tags op l = if l == [] then () else begin (* add_aaform buffer indent tags (List.hd l); *) add_aaform_list_aux errors buffer indent tags op l end and add_aaform_list_aux errors (buffer:sbuffer) indent tags op = function | [] -> () | [af] -> add_oplogic buffer indent tags op; add_aaform errors buffer indent tags af | af1::af2::l -> add_aaform errors buffer indent tags af1; append_buf buffer ~tags:(tags_spaces tags) "\n"; append_buf buffer ~tags:(tags_spaces tags) (make_indent indent); add_oplogic buffer indent tags op; add_aaform errors buffer (indent+1) tags af2; add_aaform_list errors buffer (indent+1) tags op l (* | af::l -> *) (* append_buf buffer "\n"; *) (* append_buf buffer (make_indent indent); *) (* add_oplogic buffer indent tags op; *) (* add_aaform buffer indent tags af; *) (* add_aaform_list buffer (indent+1) tags op l *) and add_aaform errors (buffer:sbuffer) indent tags ({c = af; tag = tag; ptag = ptag} as aaf) = aaf.line <- buffer#line_count; add_aform errors buffer indent (tag::ptag::tags) af let add_atyped_decl errors (buffer:sbuffer) d = match d.c with | AAxiom (loc, s, af) -> let keyword = if String.length s > 0 && (s.[0] == '_' || s.[0] == '@') then "hypothesis" else "axiom" in append_buf buffer ~tags:[d.tag;d.ptag] (sprintf "%s %s :" keyword s); append_buf buffer "\n"; d.line <- buffer#line_count; append_buf buffer (String.make indent_size ' '); add_aform errors buffer 1 [d.tag;d.ptag] af; append_buf buffer "\n\n" | ARewriting (loc, s, arwtl) -> append_buf buffer ~tags:[d.tag;d.ptag] (sprintf "rewriting %s :" s); append_buf buffer "\n"; d.line <- buffer#line_count; add_rwt_list buffer 1 [d.tag;d.ptag] arwtl; append_buf buffer "\n\n" | AGoal (loc, gs, s, aaf) -> let goal_str = match gs with Thm -> "goal" | Check -> "check" | Cut -> "cut" in append_buf buffer ~tags:[d.tag;d.ptag] (sprintf "%s %s :" goal_str s); append_buf buffer "\n"; d.line <- buffer#line_count; append_buf buffer (String.make indent_size ' '); add_aform errors buffer 1 [d.tag;d.ptag] aaf.c; append_buf buffer "\n\n" | ALogic (loc, ls, ty) -> fprintf str_formatter "logic %a : %a" print_string_list ls print_plogic_type ty; d.line <- buffer#line_count; append_buf buffer ~tags:[d.tag;d.ptag] (flush_str_formatter()); append_buf buffer "\n\n" | APredicate_def (loc, p, spptl, af) -> fprintf str_formatter "predicate %s %a =" p print_pred_type_list spptl; append_buf buffer ~tags:[d.tag;d.ptag] (flush_str_formatter()); append_buf buffer "\n"; d.line <- buffer#line_count; append_buf buffer (String.make indent_size ' '); add_aform errors buffer 1 [d.tag;d.ptag] af; append_buf buffer "\n\n" | AFunction_def (loc, f, spptl, ty, af) -> fprintf str_formatter "function %s (%a) : %a =" f print_string_ppure_type_list spptl print_ppure_type ty; append_buf buffer ~tags:[d.tag;d.ptag] (flush_str_formatter()); append_buf buffer "\n"; d.line <- buffer#line_count; append_buf buffer (String.make indent_size ' '); add_aform errors buffer 1 [d.tag;d.ptag] af; append_buf buffer "\n\n" | ATypeDecl (loc, ls, s, Abstract) -> fprintf str_formatter "type %a %s" print_astring_list ls s; d.line <- buffer#line_count; append_buf buffer ~tags:[d.tag;d.ptag] (flush_str_formatter()); append_buf buffer "\n\n" | ATypeDecl (loc, ls, s, Enum lc) -> fprintf str_formatter "type %a %s = %a" print_astring_list ls s (print_string_sep " | ") lc; d.line <- buffer#line_count; append_buf buffer ~tags:[d.tag;d.ptag] (flush_str_formatter()); append_buf buffer "\n\n" | ATypeDecl (loc, ls, s, Record rt) -> fprintf str_formatter "type %a %s = { %a }" print_astring_list ls s print_record_type rt; d.line <- buffer#line_count; append_buf buffer ~tags:[d.tag;d.ptag] (flush_str_formatter()); append_buf buffer "\n\n" let add_to_buffer errors (buffer:sbuffer) annoted_ast = List.iter (fun (t, _) -> add_atyped_decl errors buffer t) annoted_ast; commit_tags_buffer buffer let rec isin_aterm sl { at_desc = at_desc } = match at_desc with | ATconst _ -> false | ATvar sy -> List.mem (Symbols.to_string_clean sy) sl | ATapp (sy, atl) -> List.mem (Symbols.to_string_clean sy) sl || isin_aterm_list sl atl | ATinfix (t1, _, t2) | ATget (t1,t2) | ATconcat (t1, t2) | ATlet (_, t1, t2) -> isin_aterm sl t1 || isin_aterm sl t2 | ATdot (t, _ ) | ATprefix (_,t) | ATnamed (_, t) -> isin_aterm sl t | ATset (t1, t2, t3) | ATextract (t1, t2, t3) -> isin_aterm sl t1 || isin_aterm sl t2 || isin_aterm sl t3 | ATrecord rt -> let atl = List.map snd rt in isin_aterm_list sl atl and isin_aterm_list sl atl = List.fold_left (fun is at -> is || isin_aterm sl at ) false atl and findtags_aaterm sl aat acc = match aat.c.at_desc with | ATconst _ -> acc | ATvar sy -> if List.mem (Symbols.to_string_clean sy) sl then aat.tag::acc else acc | ATapp (sy, atl) -> if List.mem (Symbols.to_string_clean sy) sl || isin_aterm_list sl atl then aat.tag::acc else acc | ATinfix (t1, _, t2) | ATget (t1,t2) | ATconcat (t1, t2) | ATlet (_, t1, t2) -> if isin_aterm sl t1 || isin_aterm sl t2 then aat.tag::acc else acc | ATdot (t, _) | ATprefix (_,t) | ATnamed (_, t) -> if isin_aterm sl t then aat.tag::acc else acc | ATset (t1, t2, t3) | ATextract (t1, t2, t3) -> if isin_aterm sl t1 || isin_aterm sl t2 || isin_aterm sl t3 then aat.tag::acc else acc | ATrecord r -> let atl = List.map snd r in if isin_aterm_list sl atl then aat.tag::acc else acc and findtags_aaterm_list sl aatl acc = List.fold_left (fun acc aat -> findtags_aaterm sl aat acc ) acc aatl let findtags_aatom sl aa acc = match aa with | AAtrue | AAfalse -> acc | AAeq atl | AAneq atl | AAdistinct atl | AAle atl | AAlt atl | AAbuilt (_, atl) -> findtags_aaterm_list sl atl acc | AApred at -> acc let rec findtags_quant_form sl {aqf_triggers = trs; aqf_form = aaf } acc = let acc = findtags_triggers sl trs acc in findtags_aaform sl aaf acc and findtags_triggers sl trs acc = List.fold_left (fun acc (aatl, b) -> findtags_aaterm_list sl aatl acc ) acc trs and findtags_aform sl aform acc = match aform with | AFatom a -> findtags_aatom sl a acc | AFop (op, afl) -> findtags_aaform_list sl afl acc | AFforall qf | AFexists qf -> findtags_quant_form sl qf.c acc | AFlet (vs, sy, t, aaf) -> (* let acc = findtags_aterm sl t acc in *) let s = Symbols.to_string_clean sy in let sl = List.fold_left (fun l s' -> if Pervasives.(=) s' s then l else s'::l) [] sl in findtags_aform sl aaf.c acc | AFnamed (_, aaf) -> findtags_aform sl aaf.c acc and findtags_aaform_list sl aafl acc = List.fold_left (fun acc aaf -> findtags_aaform sl aaf acc ) acc aafl and findtags_aaform sl aaf acc = match aaf.c with | AFatom (AApred at) when isin_aterm sl at -> aaf.tag::acc | _ -> findtags_aform sl aaf.c acc let findtags_atyped_delc sl td acc = match td.c with | AAxiom (_, _, af) | APredicate_def (_, _, _, af) | AFunction_def (_, _, _, _, af) -> let aaf = (* incorrect annotations : to change *) { c = af; tag = td.tag; pruned = td.pruned; ptag = td.ptag; id = td.id; buf = td.buf; line = td.line; polarity = td.polarity; } in findtags_aaform sl aaf acc | ARewriting (_, _, rwtl) -> acc | AGoal (_, _, _, aaf) -> findtags_aform sl aaf.c acc | ALogic _ | ATypeDecl _ -> acc let findtags sl l = List.fold_left (fun acc (td, _) -> findtags_atyped_delc sl td acc ) [] l let findtags_using r l = match r with | AAxiom _ | ARewriting _ | AGoal _ | ATypeDecl _ -> [] | ALogic (_, sl, _) -> findtags sl l | APredicate_def (_, s, _, _) | AFunction_def (_, s, _, _, _) -> findtags [s] l let rec listsymbols at acc = match at.at_desc with | ATconst _ -> acc | ATvar sy -> (Symbols.to_string_clean sy)::acc | ATapp (sy, atl) -> List.fold_left (fun acc at -> listsymbols at acc) ((Symbols.to_string_clean sy)::acc) atl | ATinfix (t1, _, t2) | ATget (t1,t2) | ATconcat (t1, t2) | ATlet (_, t1, t2) -> listsymbols t1 (listsymbols t2 acc) | ATdot (t, _) | ATprefix (_,t) | ATnamed (_, t) -> listsymbols t acc | ATset (t1, t2, t3) | ATextract (t1, t2, t3) -> listsymbols t1 (listsymbols t2 (listsymbols t3 acc)) | ATrecord r -> List.fold_left (fun acc (_, at) -> listsymbols at acc) acc r and listsymbols_aform af acc = match af with | AFatom a -> listsymbols_atom a acc | AFop (_, aafl) -> List.fold_left (fun acc aaf -> listsymbols_aform aaf.c acc) acc aafl | AFforall aqf | AFexists aqf -> List.fold_left (fun acc (aatl ,_) -> List.fold_left (fun acc aat -> listsymbols aat.c acc) acc aatl ) (listsymbols_aform aqf.c.aqf_form.c acc) aqf.c.aqf_triggers | AFlet (_, _, at, aaf) -> listsymbols_aform aaf.c (listsymbols at acc) | AFnamed (_, aaf) -> listsymbols_aform aaf.c acc and listsymbols_atom a acc = match a with | AAtrue | AAfalse -> acc | AAeq aatl | AAneq aatl | AAdistinct aatl | AAle aatl | AAlt aatl | AAbuilt (_, aatl) -> List.fold_left (fun acc aat -> listsymbols aat.c acc) acc aatl | AApred at -> listsymbols at acc let listsymbols_adecl ad = match ad with | AAxiom (_,_, af) | APredicate_def (_, _, _, af) | AFunction_def (_, _, _, _, af) -> listsymbols_aform af [] | AGoal (_, _, _, aaf) -> listsymbols_aform aaf.c [] | ATypeDecl _ | ALogic _ | ARewriting _ -> [] let findtags_atyped_delc_dep sl td acc = match td.c with | ALogic (_, ls, _) -> let ne = List.fold_left (fun ne s -> ne || List.mem s sl) false ls in if ne then td.tag::acc else acc | APredicate_def (_, p, _, _) when List.mem p sl -> td.tag::acc | AFunction_def (_, f, _, _, _) when List.mem f sl -> td.tag::acc | _ -> acc let findtags_dep at l = let sl = listsymbols at [] in List.fold_left (fun acc (td, _) -> findtags_atyped_delc_dep sl td acc) [] l let findtags_dep_aform af l = let sl = listsymbols_aform af [] in List.fold_left (fun acc (td, _) -> findtags_atyped_delc_dep sl td acc) [] l let findtags_dep_adecl ad l = let sl = listsymbols_adecl ad in List.fold_left (fun acc (td, _) -> findtags_atyped_delc_dep sl td acc) [] l let rec findproof_aform ids af acc depth found = match af with | AFatom at -> acc, found | AFop ((AOPand), aafl) -> List.fold_left (fun (acc, found) aaf -> findproof_aaform ids aaf acc depth found) (acc,found) aafl | AFop (_, aafl) -> List.fold_left (fun (acc, found) aaf -> findproof_aaform ids aaf acc depth found) (acc,found) aafl | AFforall aaqf | AFexists aaqf -> let acc, found = try let m = Explanation.MI.find aaqf.id ids in MTag.add aaqf.ptag m acc, true with Not_found -> acc, found in findproof_aaform ids aaqf.c.aqf_form acc depth found | AFlet (_,_,_, aaf) | AFnamed (_, aaf) -> findproof_aaform ids aaf acc depth found and findproof_aaform ids aaf acc depth found = let acc, found = try let m = Explanation.MI.find aaf.id ids in MTag.add aaf.ptag m acc, true with Not_found -> acc, found in findproof_aform ids aaf.c acc (depth) found let findproof_atyped_decl ids td (ax,acc) = let acc = try let m = Explanation.MI.find td.id ids in MTag.add td.ptag m acc with Not_found -> acc in match td.c with | ARewriting (_,_, arwtl) -> assert false | ALogic _ | ATypeDecl _ -> ax,acc | APredicate_def (_,_,_, af) | AFunction_def (_,_,_,_, af) | AAxiom (_, _, af) -> let acc, found = findproof_aform ids af acc 1 false in if found then td.ptag::ax, acc else ax,acc | AGoal (_,_,_, aaf) -> let acc, found = findproof_aaform ids aaf acc 1 false in if found then td.ptag::ax, acc else ax,acc let findtags_proof expl l = let ids = Explanation.literals_ids_of expl in List.fold_left (fun acc (td, _) -> findproof_atyped_decl ids td acc) ([], MTag.empty) l exception FoundLine of int * GText.tag let rec find_line_id_aform id af = match af with | AFatom at -> () | AFop (_, aafl) -> List.iter (find_line_id_aaform id) aafl | AFforall aaqf | AFexists aaqf -> if aaqf.id = id then raise (FoundLine (aaqf.line, aaqf.tag)) else find_line_id_aaform id aaqf.c.aqf_form | AFlet (_,_,_, aaf) | AFnamed (_, aaf) -> find_line_id_aaform id aaf and find_line_id_aaform id aaf = if aaf.id = id then raise (FoundLine (aaf.line, aaf.tag)) else find_line_id_aform id aaf.c let find_line_id_atyped_decl id td = if td.id < id then () else if td.id = id then raise (FoundLine (td.line, td.tag)) else match td.c with | ARewriting (_,_, _) | ALogic _ | ATypeDecl _ -> () | APredicate_def (_,_,_, af) | AFunction_def (_,_,_,_, af) | AAxiom (_, _, af) -> find_line_id_aform id af | AGoal (_,_,_, aaf) -> find_line_id_aaform id aaf let find_line id l = try List.iter (fun (d, _) -> find_line_id_atyped_decl id d) l; raise Not_found with FoundLine (line, tag) -> line, tag exception Foundannot of annoted_node let findbyid_aaterm id aat = if aat.id = id then raise (Foundannot (AT aat)) (* else findbyid_atdesc id aat.c.at_desc *) (* and findbyid_atdesc id = function *) (* | ATconst _ | ATvar _ -> () *) (* | ATapp (s, atl) -> List.iter (findbyid_aaterm id) atl *) (* | ATinfix (t1, _, t2) | ATget (t1,t2) *) (* | ATconcat (t1, t2) | ATlet (_, t1, t2) -> *) (* findbyid_aaterm id t1; *) (* findbyid_aaterm id t2 *) (* | ATdot (t, _) | ATprefix (_,t) | ATnamed (_, t) -> findbyid_aaterm id t *) (* | ATset (t1, t2, t3) | ATextract (t1, t2, t3) -> *) (* findbyid_aaterm id t1; *) (* findbyid_aaterm id t2; *) (* findbyid_aaterm id t3 *) (* | ATrecord r -> *) (* let atl = List.map snd r in List.iter (findbyid_aaterm id) atl *) let findbyid_aatom id = function | AAtrue | AAfalse -> () | AAeq atl | AAneq atl | AAdistinct atl | AAle atl | AAlt atl | AAbuilt (_, atl) -> List.iter (findbyid_aaterm id) atl | AApred at -> () let rec findbyid_aform id af = match af with | AFatom aat -> findbyid_aatom id aat | AFop (_, aafl) -> List.iter (findbyid_aaform id) aafl | AFforall aaqf | AFexists aaqf -> List.iter (fun (l,_) -> List.iter (findbyid_aaterm id) l) aaqf.c.aqf_triggers; if aaqf.id = id then raise (Foundannot (QF aaqf)) else findbyid_aaform id aaqf.c.aqf_form | AFlet (_,_,_, aaf) | AFnamed (_, aaf) -> findbyid_aaform id aaf and findbyid_aaform id aaf = if aaf.id = id then raise (Foundannot (AF (aaf, None))) else findbyid_aform id aaf.c let findbyid_atyped_decl stop_decl id (td, tyenv) = if td.id < id then () else if td.id = id then raise (Foundannot (AD (td, tyenv))) else if stop_decl then raise (Foundannot (AD (td, tyenv))) else match td.c with | ARewriting (_,_, _) | ALogic _ | ATypeDecl _ -> () | APredicate_def (_,_,_, af) | AFunction_def (_,_,_,_, af) | AAxiom (_, _, af) -> findbyid_aform id af | AGoal (_,_,_, aaf) -> findbyid_aaform id aaf let findbyid_aux stop_decl id l = try List.iter (findbyid_atyped_decl stop_decl id) l; raise Not_found with Foundannot a -> a let findbyid = findbyid_aux false let findbyid_decl = findbyid_aux true let compute_resulting_ids = List.fold_left (fun acc (td, _) -> match td.c with | ARewriting (_,_, _) -> acc | ALogic (_, names, _) -> (List.map (fun n -> n, td.id) names)@acc | ATypeDecl (_, _, name, _) | APredicate_def (_, name, _, _) | AFunction_def (_, name, _, _, _) | AAxiom (_, name, _) | AGoal (_,_, name, _) -> (name, td.id)::acc) [] alt-ergo-1.30/src/gui/why_annoted.mli0000644000175000001440000002167413014515065016122 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Parsed open Typed open Gui_session type sbuffer = GSourceView2.source_buffer type error_model = { mutable some : bool; rcols : GTree.column_list; rcol_icon : GtkStock.id GTree.column; rcol_desc : String.t GTree.column; rcol_line : int GTree.column; rcol_type : int GTree.column; rcol_color : String.t GTree.column; rstore : GTree.list_store; } type inst_model = { h : (int, Gtk.tree_iter option ref * int ref * string * int ref) Hashtbl.t; mutable max : int; icols : GTree.column_list; icol_icon : GtkStock.id GTree.column; icol_desc : String.t GTree.column; icol_number : int GTree.column; icol_limit : String.t GTree.column; icol_tag : int GTree.column; istore : GTree.list_store; } type timers_model = { timers : Timers.t; label_sat : GMisc.label; label_match : GMisc.label; label_cc : GMisc.label; label_arith : GMisc.label; label_arrays : GMisc.label; label_sum : GMisc.label; label_records : GMisc.label; label_ac : GMisc.label; tl_sat : GMisc.label; tl_match : GMisc.label; tl_cc : GMisc.label; tl_arith : GMisc.label; tl_arrays : GMisc.label; tl_sum : GMisc.label; tl_records : GMisc.label; tl_ac : GMisc.label; pr_sat : GRange.progress_bar; pr_match : GRange.progress_bar; pr_cc : GRange.progress_bar; pr_arith : GRange.progress_bar; pr_arrays : GRange.progress_bar; pr_sum : GRange.progress_bar; pr_records : GRange.progress_bar; pr_ac : GRange.progress_bar; } type 'a annoted = { mutable c : 'a; mutable pruned : bool; mutable polarity : bool; tag : GText.tag; ptag : GText.tag; id : int; buf : sbuffer; mutable line : int; } type aterm = { at_ty : Ty.t; at_desc : at_desc } and at_desc = | ATconst of tconstant | ATvar of Symbols.t | ATapp of Symbols.t * aterm list | ATinfix of aterm * Symbols.t * aterm | ATprefix of Symbols.t * aterm | ATget of aterm * aterm | ATset of aterm * aterm * aterm | ATextract of aterm * aterm * aterm | ATconcat of aterm * aterm | ATlet of Symbols.t * aterm * aterm | ATdot of aterm * Hstring.t | ATrecord of (Hstring.t * aterm) list | ATnamed of Hstring.t * aterm type aatom = | AAtrue | AAfalse | AAeq of aterm annoted list | AAneq of aterm annoted list | AAdistinct of aterm annoted list | AAle of aterm annoted list | AAlt of aterm annoted list | AApred of aterm | AAbuilt of Hstring.t * aterm annoted list type aoplogic = AOPand |AOPor | AOPimp | AOPnot | AOPif of aterm | AOPiff type aquant_form = { aqf_bvars : (Symbols.t * Ty.t) list ; aqf_upvars : (Symbols.t * Ty.t) list ; mutable aqf_triggers : (aterm annoted list * bool) list ; aqf_form : aform annoted } and aform = | AFatom of aatom | AFop of aoplogic * aform annoted list | AFforall of aquant_form annoted | AFexists of aquant_form annoted | AFlet of (Symbols.t * Ty.t) list * Symbols.t * aterm * aform annoted | AFnamed of Hstring.t * aform annoted type atyped_decl = | AAxiom of Loc.t * string * aform | ARewriting of Loc.t * string * ((aterm rwt_rule) annoted) list | AGoal of Loc.t * goal_sort * string * aform annoted | ALogic of Loc.t * string list * plogic_type | APredicate_def of Loc.t * string * (string * ppure_type) list * aform | AFunction_def of Loc.t * string * (string * ppure_type) list * ppure_type * aform | ATypeDecl of Loc.t * string list * string * body_type_decl type annoted_node = | AD of (atyped_decl annoted * Why_typing.env) | AF of aform annoted * aform annoted option | AT of aterm annoted | QF of aquant_form annoted module MDep : Map.S with type key = atyped_decl annoted module MTag : Map.S with type key = GText.tag type env = { buffer : sbuffer; goal_view : GSourceView2.source_view; inst_buffer : sbuffer; inst_view : GSourceView2.source_view; errors : error_model; insts : inst_model; st_ctx : GMisc.statusbar_context; mutable ast : (atyped_decl annoted * Why_typing.env) list; mutable ctrl : bool; mutable last_tag : GText.tag; mutable search_tags : GText.tag list; mutable proof_tags : int MTag.t; mutable proof_toptags : GText.tag list; mutable start_select : int option; mutable stop_select : int option; dep : (atyped_decl annoted list * atyped_decl annoted list) MDep.t; actions : action Stack.t; saved_actions : action Stack.t; resulting_ids : (string * int) list; } val indent_size : int val monospace_font : Pango.font_description val general_font : Pango.font_description val increase_size : env list -> unit val decrease_size : env list -> unit val reset_size : env list -> unit val set_font : env list -> string -> unit val create_env : sbuffer -> GSourceView2.source_view -> sbuffer -> GSourceView2.source_view -> error_model -> inst_model -> GMisc.statusbar_context -> (atyped_decl annoted * Why_typing.env) list -> (atyped_decl annoted list * atyped_decl annoted list) MDep.t -> action Stack.t -> (string * int) list -> env val create_replay_env : sbuffer -> error_model -> inst_model -> (atyped_decl annoted * Why_typing.env) list -> action Stack.t -> (string * int) list -> env val find : GText.tag -> sbuffer -> (atyped_decl annoted * Why_typing.env) list -> annoted_node option val find_decl : GText.tag -> sbuffer -> (atyped_decl annoted * Why_typing.env) list -> annoted_node option val find_tag_inversedeps : (atyped_decl annoted list * atyped_decl annoted list) MDep.t -> GText.tag -> atyped_decl annoted list option val find_tag_deps : (atyped_decl annoted list * atyped_decl annoted list) MDep.t -> GText.tag -> atyped_decl annoted list option val make_dep : (atyped_decl annoted * Why_typing.env) list -> (atyped_decl annoted list * atyped_decl annoted list) MDep.t val tag : sbuffer -> GText.tag val new_annot : sbuffer -> 'a -> int -> GText.tag -> 'a annoted val annot : sbuffer -> ((int tdecl, int) Typed.annoted * Why_typing.env) list -> (atyped_decl annoted * Why_typing.env) list val annot_of_tterm : sbuffer -> (int tterm, int) Typed.annoted -> aterm annoted val add_aaterm_list_at : sbuffer -> GText.tag list -> GText.iter -> string -> aterm annoted list -> unit val add_aaform : error_model -> sbuffer -> int -> GText.tag list -> aform annoted -> unit val to_ast : (atyped_decl annoted * Why_typing.env) list -> (int tdecl, int) Typed.annoted list val add_to_buffer : error_model -> sbuffer -> (atyped_decl annoted * Why_typing.env) list -> unit val print_typed_decl_list : Format.formatter -> (int tdecl, int) Typed.annoted list -> unit val findtags_using : atyped_decl -> (atyped_decl annoted * Why_typing.env) list -> GText.tag list val findtags_dep : aterm -> (atyped_decl annoted * Why_typing.env) list -> GText.tag list val findtags_dep_aform : aform -> (atyped_decl annoted * Why_typing.env) list -> GText.tag list val findtags_dep_adecl : atyped_decl -> (atyped_decl annoted * Why_typing.env) list -> GText.tag list val findtags_proof : Explanation.t -> (atyped_decl annoted * Why_typing.env) list -> GText.tag list * int MTag.t val find_line : int -> (atyped_decl annoted * 'a) list -> int * GText.tag val findbyid : int -> (atyped_decl annoted * Why_typing.env) list -> annoted_node val findbyid_decl : int -> (atyped_decl annoted * Why_typing.env) list -> annoted_node val compute_resulting_ids : (atyped_decl annoted * Why_typing.env) list -> (string * int) list val commit_tags_buffer : sbuffer -> unit alt-ergo-1.30/src/gui/gui_replay.ml0000644000175000001440000001002613014515065015557 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Gui_session open Why_annoted open Why_connected open Options let replay_prune id env = match findbyid id env.ast with | AD (ad, _) -> prune ~register:false env ad | AF (af, _) -> prune ~register:false env af | AT at -> prune ~register:false env at | QF aq -> prune ~register:false env aq let replay_incorrect_prune id env = match findbyid id env.ast with | AD (ad, _) -> incorrect_prune ~register:false env ad | AF (af, _) -> incorrect_prune ~register:false env af | AT at -> incorrect_prune ~register:false env at | QF aq -> incorrect_prune ~register:false env aq let replay_unprune id env = match findbyid id env.ast with | AD (ad, _) -> unprune ~register:false env ad | AF (af, _) -> unprune ~register:false env af | AT at -> unprune ~register:false env at | QF aq -> unprune ~register:false env aq let replay_addinstance id aname entries env = match findbyid id env.ast with | AD (ad, _) -> begin match ad.c with | AAxiom (_, aname, af) -> add_instance ~register:false env id af aname entries | APredicate_def (_, aname,_ , af) -> add_instance ~register:false env id af aname entries | _ -> assert false end | _ -> assert false let replay_limitlemma id name nb env = Hashtbl.add env.insts.h id (ref None, ref 0, name, ref nb) let replay env = function | Prune id -> replay_prune id env | IncorrectPrune id -> replay_incorrect_prune id env | Unprune id -> replay_unprune id env | AddInstance (id, aname, entries) -> replay_addinstance id aname entries env | AddTrigger (id, inst_buf, str) -> readd_trigger ~register:false env id str inst_buf | LimitLemma (id, name, nb) -> replay_limitlemma id name nb env | UnlimitLemma (id, name) -> replay_limitlemma id name (-1) env let replay_session env = let l = ref [] in Stack.iter (fun a -> l := a::!l) env.actions; List.iter (replay env) !l let undo_action env = match Stack.pop env.actions with | Prune id | IncorrectPrune id -> replay env (Unprune id) | Unprune id -> replay env (Prune id) | ((AddInstance _ | AddTrigger _ ) as ac) -> replay env (Prune (Hashtbl.find resulting_ids ac)) | LimitLemma (id, name, _) | UnlimitLemma (id, name) -> try Stack.iter (function | (LimitLemma (id', _, _) | UnlimitLemma (id', _) as ac) when id = id' -> replay env ac; raise Exit | _ -> ()) env.actions; replay env (LimitLemma (id, name, -1)) with Exit -> () alt-ergo-1.30/src/gui/why_connected.mli0000644000175000001440000000422213014515065016422 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Why_annoted val prune : ?register:bool -> env -> 'a annoted -> unit val incorrect_prune : ?register:bool -> env -> 'a annoted -> unit val unprune : ?register:bool -> env -> 'a annoted -> unit val toggle_prune : env -> 'a annoted -> unit val connect : env -> unit val clear_used_lemmas_tags : env -> unit val show_used_lemmas : env -> Explanation.t -> unit val prune_unused : env -> unit val add_instance : ?register:bool -> env -> int -> aform -> string -> string list -> unit val readd_trigger : ?register:bool -> env -> int -> string -> bool -> unit alt-ergo-1.30/src/gui/gui_session.mli0000644000175000001440000000402013014515065016114 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type action = | Prune of int | IncorrectPrune of int | Unprune of int | AddInstance of int * string * string list | AddTrigger of int * bool * string | LimitLemma of int * string * int | UnlimitLemma of int * string val resulting_ids : (action, int) Hashtbl.t val save : action Stack.t -> action -> unit val read_actions : (string * int) list -> in_channel option -> action Stack.t val safe_session : action Stack.t -> bool alt-ergo-1.30/src/gui/gui_session.ml0000644000175000001440000001065513014515065015756 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options type action = | Prune of int | IncorrectPrune of int | Unprune of int | AddInstance of int * string * string list | AddTrigger of int * bool * string | LimitLemma of int * string * int | UnlimitLemma of int * string let resulting_ids = Hashtbl.create 17 let save actions ac = (* (match ac with *) (* | Prune id -> Format.eprintf "Prune %d@." id *) (* | IncorrectPrune id -> Format.eprintf "Incorrectprune %d@." id *) (* | Unprune id -> Format.eprintf "Unrune %d@." id *) (* | AddInstance (id, name, vars) -> *) (* Format.eprintf "AddInstance %d %s@." id name *) (* | AddTrigger (id, inst_buf, trs) -> *) (* Format.eprintf "AddTriger %d %b %s@." id inst_buf trs *) (* | LimitLemma (id, name, nb) -> *) (* Format.eprintf "LimitLemma %d-%s %d@." id name nb *) (* ); *) Stack.push ac actions let compute_ids_offsets old_res res = List.fold_left (fun acc (name1, id1) -> try let id2 = List.assoc name1 res in (* if id1 = id2 then acc else *) (id1, id2 - id1)::acc with Not_found -> acc) [] old_res let offset_id id offsets = let nid = ref id in try List.iter (fun (i, off) -> if id <= i then (nid := id + off; raise Exit)) offsets; id with Exit -> !nid let offset_stack st offsets = let l = ref [] in while not (Stack.is_empty st) do let ac = match Stack.pop st with | Prune id -> Prune (offset_id id offsets) | IncorrectPrune id -> IncorrectPrune (offset_id id offsets) | Unprune id -> Unprune (offset_id id offsets) | AddInstance (id, name, vars) -> AddInstance ((offset_id id offsets), name, vars) | AddTrigger (id, inst_buf, trs) -> AddTrigger ((offset_id id offsets), inst_buf, trs) | LimitLemma (id, name, nb) -> LimitLemma ((offset_id id offsets), name, nb) | UnlimitLemma (id, name) -> UnlimitLemma ((offset_id id offsets), name) in l := ac :: !l done; List.iter (fun ac -> Stack.push ac st) !l let read_actions res = function | Some cin -> begin try let old_res = (input_value cin: (string * int) list) in let st = (input_value cin: action Stack.t) in let offsets = compute_ids_offsets old_res res in offset_stack st offsets; st with End_of_file -> Stack.create () end | None -> Stack.create () module SI = Set.Make (struct type t = int let compare = compare end) let safe_session actions = let l = ref [] in Stack.iter (fun a -> l := a::!l) actions; let list_actions = !l in let _, incorrect_prunes = List.fold_left (fun (prunes, incorrect_prunes) -> function | Prune id -> SI.add id prunes, incorrect_prunes | IncorrectPrune id -> prunes, SI.add id incorrect_prunes | Unprune id -> SI.remove id prunes, SI.remove id incorrect_prunes | _ -> prunes, incorrect_prunes) (SI.empty, SI.empty) list_actions in SI.is_empty incorrect_prunes alt-ergo-1.30/src/parsing/0000755000175000001440000000000013014515065013745 5ustar rtusersalt-ergo-1.30/src/parsing/why_lexer.mll0000644000175000001440000001526213014515065016467 0ustar rtusers(* * The Why certification tool * Copyright (C) 2002 Jean-Christophe FILLIATRE * * This software is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public * License version 2, as published by the Free Software Foundation. * * This software is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * See the GNU General Public License version 2 for more details * (enclosed in the file GPL). *) (* $Id: why_lexer.mll,v 1.26 2011-02-24 15:35:48 mebsout Exp $ *) { open Lexing open Why_parser open Format open Options let keywords = Hashtbl.create 97 let () = List.iter (fun (x,y) -> Hashtbl.add keywords x y) [ "ac", AC; "and", AND; "axiom", AXIOM; "bitv", BITV; "bool", BOOL; "check", CHECK; "cut", CUT; "distinct", DISTINCT; "else", ELSE; "exists", EXISTS; "false", FALSE; "forall", FORALL; "function", FUNCTION; "goal", GOAL; "if", IF; "in", IN; "int", INT; "let", LET; "logic", LOGIC; "not", NOT; "or", OR; "predicate", PREDICATE; "prop", PROP; "real", REAL; "rewriting", REWRITING; "then", THEN; "true", TRUE; "type", TYPE; "unit", UNIT; "void", VOID; "with", WITH; ] let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } let string_buf = Buffer.create 1024 exception Lexical_error of string let char_for_backslash = function | 'n' -> '\n' | 't' -> '\t' | c -> c let num0 = Num.Int 0 let num10 = Num.Int 10 let num16 = Num.Int 16 let decnumber s = let r = ref num0 in for i=0 to String.length s - 1 do r := Num.add_num (Num.mult_num num10 !r) (Num.num_of_int (Char.code s.[i] - Char.code '0')) done; !r let hexnumber s = let r = ref num0 in for i=0 to String.length s - 1 do let c = s.[i] in let v = match c with | '0'..'9' -> Char.code c - Char.code '0' | 'a'..'f' -> Char.code c - Char.code 'a' + 10 | 'A'..'F' -> Char.code c - Char.code 'A' + 10 | _ -> assert false in r := Num.add_num (Num.mult_num num16 !r) (Num.num_of_int v) done; !r } let newline = '\n' let space = [' ' '\t' '\r'] let alpha = ['a'-'z' 'A'-'Z'] let letter = alpha | '_' let digit = ['0'-'9'] let hexdigit = ['0'-'9''a'-'f''A'-'F'] let ident = (letter | '?') (letter | digit | '?' | '\'')* rule token = parse | newline { newline lexbuf; token lexbuf } | space+ { token lexbuf } | ident as id (* identifiers *) { try let k = Hashtbl.find keywords id in Options.tool_req 0 "TR-Lexical-keyword"; k with Not_found -> Options.tool_req 0 "TR-Lexical-identifier"; IDENT id } | digit+ as s (* integers *) { Options.tool_req 0 "TR-Lexical-integer"; INTEGER s } | (digit+ as i) ("" as f) ['e' 'E'] (['-' '+']? as sign (digit+ as exp)) | (digit+ as i) '.' (digit* as f) (['e' 'E'] (['-' '+']? as sign (digit+ as exp)))? | (digit* as i) '.' (digit+ as f) (['e' 'E'] (['-' '+']? as sign (digit+ as exp)))? (* decimal real literals *) { (* Format.eprintf "decimal real literal found: i=%s f=%s sign=%a exp=%a" i f so sign so exp; *) Options.tool_req 0 "TR-Lexical-real"; let v = match exp,sign with | Some exp,Some "-" -> Num.div_num (decnumber (i^f)) (Num.power_num (Num.Int 10) (decnumber exp)) | Some exp,_ -> Num.mult_num (decnumber (i^f)) (Num.power_num (Num.Int 10) (decnumber exp)) | None,_ -> decnumber (i^f) in let v = Num.div_num v (Num.power_num (Num.Int 10) (Num.num_of_int (String.length f))) in (* Format.eprintf " -> value = %s@." (Num.string_of_num v); *) NUM v } (* hexadecimal real literals a la C99 (0x..p..) *) | "0x" (hexdigit+ as e) ('.' (hexdigit* as f))? ['p''P'] (['+''-']? as sign) (digit+ as exp) { (* Format.eprintf "hex num found: %s" (lexeme lexbuf); *) Options.tool_req 0 "TR-Lexical-hexponent"; Options.tool_req 0 "TR-Lexical-hexa"; let f = match f with None -> "" | Some f -> f in let v = match sign with | "-" -> Num.div_num (hexnumber (e^f)) (Num.power_num (Num.Int 2) (decnumber exp)) | _ -> Num.mult_num (hexnumber (e^f)) (Num.power_num (Num.Int 2) (decnumber exp)) in let v = Num.div_num v (Num.power_num (Num.Int 16) (Num.num_of_int (String.length f))) in (* Format.eprintf " -> value = %s@." (Num.string_of_num v); *) NUM v } | "(*" { comment lexbuf; token lexbuf } | "'" { QUOTE } | "," { COMMA } | ";" { PV } | "(" { LEFTPAR } | ")" { RIGHTPAR } | ":" { COLON } | "->" { Options.tool_req 0 "TR-Lexical-operator"; ARROW } | "<-" { Options.tool_req 0 "TR-Lexical-operator"; LEFTARROW } | "<->" { Options.tool_req 0 "TR-Lexical-operator"; LRARROW } | "=" { Options.tool_req 0 "TR-Lexical-operator"; EQUAL } | "<" { Options.tool_req 0 "TR-Lexical-operator"; LT } | "<=" { Options.tool_req 0 "TR-Lexical-operator"; LE } | ">" { Options.tool_req 0 "TR-Lexical-operator"; GT } | ">=" { Options.tool_req 0 "TR-Lexical-operator"; GE } | "<>" { Options.tool_req 0 "TR-Lexical-operator"; NOTEQ } | "+" { Options.tool_req 0 "TR-Lexical-operator"; PLUS } | "-" { Options.tool_req 0 "TR-Lexical-operator"; MINUS } | "*" { Options.tool_req 0 "TR-Lexical-operator"; TIMES } | "/" { Options.tool_req 0 "TR-Lexical-operator"; SLASH } | "%" { Options.tool_req 0 "TR-Lexical-operator"; PERCENT } | "@" { Options.tool_req 0 "TR-Lexical-operator"; AT } | "." { DOT } | "[" { LEFTSQ } | "]" { RIGHTSQ } | "{" { LEFTBR } | "}" { RIGHTBR } | "|" { BAR } | "^" { HAT } | "\"" { Buffer.clear string_buf; string lexbuf } | eof { EOF } | _ as c { raise (Lexical_error ("illegal character: " ^ String.make 1 c)) } and comment = parse | "*)" { () } | "(*" { comment lexbuf; comment lexbuf } | newline { newline lexbuf; comment lexbuf } | eof { raise (Lexical_error "unterminated comment") } | _ { comment lexbuf } and string = parse | "\"" { Options.tool_req 0 "TR-Lexical-string"; STRING (Buffer.contents string_buf) } | "\\" (_ as c) { Buffer.add_char string_buf (char_for_backslash c); string lexbuf } | newline { newline lexbuf; Buffer.add_char string_buf '\n'; string lexbuf } | eof { raise (Lexical_error "unterminated string") } | _ as c { Buffer.add_char string_buf c; string lexbuf } alt-ergo-1.30/src/parsing/why_parser.mly0000644000175000001440000003025013014515065016653 0ustar rtusers/* * The Why certification tool * Copyright (C) 2002 Jean-Christophe FILLIATRE * * This software is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public * License version 2, as published by the Free Software Foundation. * * This software is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * See the GNU General Public License version 2 for more details * (enclosed in the file GPL). */ /* from http://www.lysator.liu.se/c/ANSI-C-grammar-y.html */ %{ open Parsed open Parsing open Format open Options let loc () = (symbol_start_pos (), symbol_end_pos ()) let loc_i i = (rhs_start_pos i, rhs_end_pos i) let loc_ij i j = (rhs_start_pos i, rhs_end_pos j) let mk_ppl loc d = { pp_loc = loc; pp_desc = d } let mk_pp d = mk_ppl (loc ()) d let mk_pp_i i d = mk_ppl (loc_i i) d let infix_ppl loc a i b = mk_ppl loc (PPinfix (a, i, b)) let infix_pp a i b = infix_ppl (loc ()) a i b let prefix_ppl loc p a = mk_ppl loc (PPprefix (p, a)) let prefix_pp p a = prefix_ppl (loc ()) p a let check_binary_mode s = String.iter (fun x -> match x with | '0' | '1' -> () | _ -> raise Parsing.Parse_error) s; s %} /* Tokens */ %token IDENT %token INTEGER %token FLOAT %token NUM %token STRING %token WITH %token AND LEFTARROW ARROW AC AT AXIOM REWRITING %token BAR HAT %token BOOL COLON COMMA PV DISTINCT DOT ELSE EOF EQUAL %token EXISTS FALSE VOID FORALL FUNCTION GE GOAL GT CHECK CUT ADDTERM %token IF IN INT BITV %token LE LET LEFTPAR LEFTSQ LEFTBR LOGIC LRARROW LT MINUS %token NOT NOTEQ OR PERCENT PLUS PREDICATE PROP %token QUOTE REAL UNIT %token RIGHTPAR RIGHTSQ RIGHTBR %token SLASH %token THEN TIMES TRUE TYPE /* Precedences */ %nonassoc WITH %nonassoc IN %nonassoc prec_forall prec_exists %right ARROW LRARROW %right OR %right AND %nonassoc prec_ite %left prec_relation EQUAL NOTEQ LT LE GT GE %left PLUS MINUS %left TIMES SLASH PERCENT AT %nonassoc HAT %nonassoc uminus %nonassoc NOT DOT %right prec_named %nonassoc CHECK CUT ADDTERM %left LEFTSQ %nonassoc LIDENT /* Entry points */ %type trigger %start trigger %type lexpr %start lexpr %type file %start file %% file: | list1_decl EOF { Options.tool_req 0 "TR-Lexical-file"; $1 } | EOF { Options.tool_req 0 "TR-Lexical-file"; [] } ; list1_decl: | decl { [$1] } | decl list1_decl { $1 :: $2 } ; decl: | TYPE type_vars ident { Options.tool_req 0 "TR-Lexical-decl"; TypeDecl (loc_ij 1 2, $2, $3, Abstract) } | TYPE type_vars ident EQUAL list1_constructors_sep_bar { Options.tool_req 0 "TR-Lexical-decl"; TypeDecl (loc_i 2, $2, $3, Enum $5 ) } | TYPE type_vars ident EQUAL record_type { Options.tool_req 0 "TR-Lexical-decl"; TypeDecl (loc_i 2, $2, $3, Record $5 ) } | LOGIC ac_modifier list1_named_ident_sep_comma COLON logic_type { Options.tool_req 0 "TR-Lexical-decl"; Logic (loc (), $2, $3, $5) } | FUNCTION named_ident LEFTPAR list0_logic_binder_sep_comma RIGHTPAR COLON primitive_type EQUAL lexpr { Options.tool_req 0 "TR-Lexical-decl"; Function_def (loc (), $2, $4, $7, $9) } | PREDICATE named_ident EQUAL lexpr { Options.tool_req 0 "TR-Lexical-decl"; Predicate_def (loc (), $2, [], $4) } | PREDICATE named_ident LEFTPAR list0_logic_binder_sep_comma RIGHTPAR EQUAL lexpr { Options.tool_req 0 "TR-Lexical-decl"; Predicate_def (loc (), $2, $4, $7) } | AXIOM ident COLON lexpr { Options.tool_req 0 "TR-Lexical-decl"; Axiom (loc (), $2, $4) } | REWRITING ident COLON list1_lexpr_sep_pv { Options.tool_req 0 "TR-Lexical-decl"; Rewriting(loc (), $2, $4) } | GOAL ident COLON lexpr { Options.tool_req 0 "TR-Lexical-decl"; Goal (loc (), $2, $4) } ; ac_modifier: /* */ { Symbols.Other } | AC { Symbols.Ac } primitive_type: | INT { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTint } | BOOL { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTbool } | REAL { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTreal } | UNIT { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTunit } | BITV LEFTSQ INTEGER RIGHTSQ { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTbitv(int_of_string $3) } | ident { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTexternal ([], $1, loc ()) } | type_var { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTvarid ($1, loc ()) } | primitive_type ident { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTexternal ([$1], $2, loc_i 2) } | LEFTPAR list1_primitive_type_sep_comma RIGHTPAR ident { Options.tool_req 0 "TR-Lexical-primitive-type"; PPTexternal ($2, $4, loc_i 4) } ; logic_type: | list0_primitive_type_sep_comma ARROW PROP { Options.tool_req 0 "TR-Lexical-logic-type"; PPredicate $1 } | PROP { Options.tool_req 0 "TR-Lexical-logic-type"; PPredicate [] } | list0_primitive_type_sep_comma ARROW primitive_type { Options.tool_req 0 "TR-Lexical-logic-type"; PFunction ($1, $3) } | primitive_type { Options.tool_req 0 "TR-Lexical-logic-type"; PFunction ([], $1) } ; list1_primitive_type_sep_comma: | primitive_type { [$1] } | primitive_type COMMA list1_primitive_type_sep_comma { $1 :: $3 } ; list0_primitive_type_sep_comma: | /* epsilon */ { [] } | list1_primitive_type_sep_comma { $1 } ; list0_logic_binder_sep_comma: | /* epsilon */ { [] } | list1_logic_binder_sep_comma { $1 } ; list1_logic_binder_sep_comma: | logic_binder { [$1] } | logic_binder COMMA list1_logic_binder_sep_comma { $1 :: $3 } ; logic_binder: | ident COLON primitive_type { Options.tool_req 0 "TR-Lexical-logic-binder"; (loc_i 1, $1, $3) } ; list1_constructors_sep_bar: | ident { [$1] } | ident BAR list1_constructors_sep_bar { $1 :: $3} ; lexpr: | simple_expr { $1 } /* binary operators */ | lexpr PLUS lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPadd $3 } | lexpr MINUS lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPsub $3 } | lexpr TIMES lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPmul $3 } | lexpr SLASH lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPdiv $3 } | lexpr PERCENT lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPmod $3 } | lexpr AND lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPand $3 } | lexpr OR lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPor $3 } | lexpr LRARROW lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPiff $3 } | lexpr ARROW lexpr { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 PPimplies $3 } | lexpr relation lexpr %prec prec_relation { Options.tool_req 0 "TR-Lexical-expr"; infix_pp $1 $2 $3 } /* unary operators */ | NOT lexpr { Options.tool_req 0 "TR-Lexical-expr"; prefix_pp PPnot $2 } | MINUS lexpr %prec uminus { Options.tool_req 0 "TR-Lexical-expr"; prefix_pp PPneg $2 } /* bit vectors */ | LEFTSQ BAR INTEGER BAR RIGHTSQ { Options.tool_req 0 "TR-Lexical-bitv"; Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPconst (ConstBitv (check_binary_mode $3))) } | lexpr HAT LEFTBR INTEGER COMMA INTEGER RIGHTBR { Options.tool_req 0 "TR-Lexical-expr"; let i = mk_pp (PPconst (ConstInt $4)) in let j = mk_pp (PPconst (ConstInt $6)) in mk_pp (PPextract ($1, i, j)) } | lexpr AT lexpr { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPconcat($1, $3)) } /* predicate or function calls */ | DISTINCT LEFTPAR list2_lexpr_sep_comma RIGHTPAR { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPdistinct $3) } | IF lexpr THEN lexpr ELSE lexpr %prec prec_ite { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPif ($2, $4, $6)) } | FORALL list1_named_ident_sep_comma COLON primitive_type triggers DOT lexpr %prec prec_forall { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPforall_named ($2, $4, $5, $7)) } | EXISTS list1_named_ident_sep_comma COLON primitive_type triggers DOT lexpr %prec prec_exists { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPexists_named ($2, $4, $5, $7)) } | STRING COLON lexpr %prec prec_named { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPnamed ($1, $3)) } | LET ident EQUAL lexpr IN lexpr { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPlet ($2, $4, $6)) } | CHECK lexpr { mk_pp (PPcheck $2) } | CUT lexpr { mk_pp (PPcut $2) } ; simple_expr : /* constants */ | INTEGER { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPconst (ConstInt $1)) } | NUM { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPconst (ConstReal $1)) } | TRUE { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPconst ConstTrue) } | FALSE { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPconst ConstFalse) } | VOID { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPconst ConstVoid) } | ident { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPvar $1) } /* records */ | LEFTBR list1_label_expr_sep_PV RIGHTBR { mk_pp (PPrecord $2) } | LEFTBR simple_expr WITH list1_label_expr_sep_PV RIGHTBR { mk_pp (PPwith($2, $4)) } | simple_expr DOT ident { mk_pp (PPdot($1, $3)) } /* function or predicat calls */ | ident LEFTPAR list0_lexpr_sep_comma RIGHTPAR { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPapp ($1, $3)) } /* arrays */ | simple_expr LEFTSQ lexpr RIGHTSQ { Options.tool_req 0 "TR-Lexical-expr"; mk_pp(PPget($1, $3)) } | simple_expr LEFTSQ array_assignements RIGHTSQ { Options.tool_req 0 "TR-Lexical-expr"; let acc, l = match $3 with | [] -> assert false | (i, v)::l -> mk_pp (PPset($1, i, v)), l in List.fold_left (fun acc (i,v) -> mk_pp (PPset(acc, i, v))) acc l } | LEFTPAR lexpr RIGHTPAR { Options.tool_req 0 "TR-Lexical-expr"; $2 } | simple_expr COLON primitive_type { Options.tool_req 0 "TR-Lexical-expr"; mk_pp (PPcast($1,$3)) } ; array_assignements: | array_assignement { [$1] } | array_assignement COMMA array_assignements { $1 :: $3 } ; array_assignement: | lexpr LEFTARROW lexpr { $1, $3 } ; triggers: | /* epsilon */ { Options.tool_req 0 "TR-Lexical-triggers"; [] } | LEFTSQ list1_trigger_sep_bar RIGHTSQ { Options.tool_req 0 "TR-Lexical-triggers"; $2 } ; list1_trigger_sep_bar: | trigger { [$1] } | trigger BAR list1_trigger_sep_bar { $1 :: $3 } ; trigger: list1_lexpr_sep_comma { Options.tool_req 0 "TR-Lexical-trigger"; ($1, true) } ; list1_lexpr_sep_pv: | lexpr { [$1] } | lexpr PV { [$1] } | lexpr PV list1_lexpr_sep_pv { $1 :: $3 } ; list0_lexpr_sep_comma: | /*empty */ { [] } | lexpr { [$1] } | lexpr COMMA list1_lexpr_sep_comma { $1 :: $3 } ; list1_lexpr_sep_comma: | lexpr { [$1] } | lexpr COMMA list1_lexpr_sep_comma { $1 :: $3 } ; list2_lexpr_sep_comma: | lexpr COMMA lexpr { [$1; $3] } | lexpr COMMA list2_lexpr_sep_comma { $1 :: $3 } ; relation: | LT { PPlt } | LE { PPle } | GT { PPgt } | GE { PPge } | EQUAL { PPeq } | NOTEQ { PPneq } ; record_type: | LEFTBR list1_label_sep_PV RIGHTBR { $2 } ; list1_label_sep_PV: | label_with_type { [$1] } | label_with_type PV list1_label_sep_PV { $1::$3 } ; label_with_type: | ident COLON primitive_type { $1,$3 } ; list1_label_expr_sep_PV: | ident EQUAL lexpr { [$1, $3] } | ident EQUAL lexpr PV list1_label_expr_sep_PV { ($1, $3) :: $5 } ; type_var: | QUOTE ident { Options.tool_req 0 "TR-Lexical-car-type"; $2 } ; type_vars: | /* empty */ { [] } | type_var { [$1] } | LEFTPAR list1_type_var_sep_comma RIGHTPAR { $2 } list1_type_var_sep_comma: | type_var { [$1] } | type_var COMMA list1_type_var_sep_comma { $1 :: $3 } ; ident: | IDENT { $1 } ; list1_named_ident_sep_comma: | named_ident { [$1] } | named_ident COMMA list1_named_ident_sep_comma { $1 :: $3 } ; named_ident: | IDENT { $1, "" } | IDENT STRING { $1, $2 } ; alt-ergo-1.30/src/util/0000755000175000001440000000000013014515065013257 5ustar rtusersalt-ergo-1.30/src/util/options.ml0000644000175000001440000005261213014515065015312 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) let fmt = Format.err_formatter module M = struct let file = ref "" let session_file = ref "" let used_context_file = ref "" let rewriting = ref false let type_only = ref false let parse_only = ref false let steps_bound = ref (-1) let age_bound = ref 50 let debug = ref false let debug_warnings = ref false let notriggers = ref false let debug_cc = ref false let debug_gc = ref false let debug_use = ref false let debug_arrays = ref false let debug_uf = ref false let debug_sat = ref false let debug_sat_simple = ref false let debug_typing = ref false let debug_constr = ref false let verbose = ref false let debug_fm = ref false let debug_sum = ref false let debug_arith = ref false let debug_combine = ref false let debug_bitv = ref false let debug_ac = ref false let debug_split = ref false let options = ref false let greedy = ref false let triggers_var = ref false let nb_triggers = ref 2 let enable_assertions = ref false let rm_eq_existential = ref false let no_Ematching = ref false let no_backjumping = ref false let nocontracongru = ref false let term_like_pp = ref true let debug_types = ref false let all_models = ref false let model = ref false let complete_model = ref false let interpretation = ref 0 let debug_interpretation = ref false let proof = ref false let debug_proof = ref false let rules = ref (-1) let max_split = ref (Numbers.Q.from_int 1000000) let fm_cross_limit = ref (Numbers.Q.from_int 10_000) let case_split_policy = ref Util.AfterTheoryAssume let restricted = ref false let bottom_classes = ref false let timelimit = ref 0. let interpretation_timelimit = ref (if Sys.win32 then 0. else 1.) let debug_matching = ref 0 let debug_explanations = ref false let sat_plugin = ref "" let inequalities_plugin = ref "" let profiling_plugin = ref "" let cumulative_time_profiling = ref false let normalize_instances = ref false let partial_bmodel = ref true let tighten_vars = ref false let no_tcp = ref false let no_theory = ref false let js_mode = ref false let no_NLA = ref false let no_ac = ref false let instantiate_after_backjump = ref false let show_where s= match s with | "" -> () | s -> let path = match s with | "bin" -> Config.bindir | "lib" -> Config.libdir | "plugins" -> Config.pluginsdir | "data" -> Config.datadir | "man" -> Config.mandir | s -> raise (Arg.Bad ("Option -where has no argument " ^ s)) in Format.printf "%s@." path; exit 0 let show_version () = Format.printf "%s@." Version.version; exit 0 let show_version_info () = Format.printf "Version = %s@." Version.version; Format.printf "Release date = %s@." Version.release_date; Format.printf "Release commit = %s@." Version.release_commit; Format.printf "Compilation date = %s@." Config.date; exit 0 let set_max_split s = max_split := try Numbers.Q.from_string s with Failure _ -> Numbers.Q.m_one let set_fm_cross_limit s = fm_cross_limit := try Numbers.Q.from_string s with Failure _ -> Numbers.Q.m_one let set_sat_plugin s = sat_plugin := s let set_inequalities_plugin s = inequalities_plugin := s let set_profiling_plugin s = profiling_plugin := s let set_proof b = proof := b let set_rules = function | "parsing" -> rules := 0 | "typing" -> rules := 1 | "sat" -> rules := 2 | "cc" -> rules := 3 | "arith" -> rules := 4 | _ -> rules := -1 let set_limit timelimit_target t = if Sys.win32 then Format.eprintf "timelimit not supported on Win32 (ignored)@." else timelimit_target := t let replay = ref false let replay_used_context = ref false let replay_all_used_context = ref false let save_used_context = ref false let replay_satml_dfs = ref false let profiling_period = ref 0. let profiling = ref false let parse_profiling s = profiling := true; try profiling_period := float_of_string s with _ -> () let set_case_split_policy_option s = case_split_policy := match s with | "after-theory-assume" -> Util.AfterTheoryAssume | "before-matching" -> Util.BeforeMatching | "after-matching" -> Util.AfterMatching | _ -> raise (Arg.Bad ("Bad value '"^s^"' for option -case-split-policy")) let timers = ref false let usage = "usage: alt-ergo [options] file." let spec = [ (* "-stats", Arg.Set stats, " activate statistics recording and printing (use Ctrl-C to print them in the terminal)"; *) "-parse-only", Arg.Set parse_only, " stop after parsing"; "-type-only", Arg.Set type_only , " stop after typing"; "-notriggers", Arg.Set notriggers, " disable triggers inference"; "-debug", Arg.Set debug, " sets the debugging flag"; "-dwarnings", Arg.Set debug_warnings, " sets the debugging flag of warnings"; "-dcc", Arg.Set debug_cc, " sets the debugging flag of cc"; "-dgc", Arg.Set debug_gc, " prints some debug info about the GC's activity"; "-duse", Arg.Set debug_use, " sets the debugging flag of use"; "-duf", Arg.Set debug_uf, " sets the debugging flag of uf"; "-dfm", Arg.Set debug_fm, " sets the debugging flag of inequalities"; "-dsum", Arg.Set debug_sum, " sets the debugging flag of Sum"; "-darith", Arg.Set debug_arith, " sets the debugging flag of Arith (without fm)"; "-dbitv", Arg.Set debug_bitv, " sets the debugging flag of bitv"; "-dac", Arg.Set debug_ac, " sets the debugging flag of ac"; "-dsat", Arg.Set debug_sat, " sets the debugging flag of sat"; "-dsats", Arg.Set debug_sat_simple, " sets the debugging flag of sat (simple output)"; "-dtyping", Arg.Set debug_typing, " sets the debugging flag of typing"; "-types", Arg.Set debug_types, " sets the debugging flag of types"; "-dconstr", Arg.Set debug_constr, " sets the debugging flag of constructors"; "-darrays", Arg.Set debug_arrays, " sets the debugging flag of arrays"; "-dcombine", Arg.Set debug_combine, " sets the debugging flag of combine"; "-dsplit", Arg.Set debug_split, " sets the debugging flag of case-split analysis"; "-dmatching", Arg.Set_int debug_matching, " sets the debugging flag of E-matching (0 = disabled, 1 = light, 2 = full)"; "-dexplanations", Arg.Set debug_explanations, " sets the debugging flag of explanations"; "-verbose", Arg.Set verbose, " sets the verbose mode"; "-version", Arg.Unit show_version, " prints the version number"; "-version-info", Arg.Unit show_version_info, " prints some info about this version"; "-where", Arg.String show_where, " prints the directory of its argument. Possible arguments are: \"bin\", \"lib\", \"plugins\", \"data\" and \"man\""; "-steps-bound", Arg.Set_int steps_bound, " set the maximum number of steps"; "-no-tcp", Arg.Set no_tcp, " Deactivate BCP modulo theories"; "-tighten-vars", Arg.Set tighten_vars, " Compute the best bounds for arithmetic variables"; "-no-theory", Arg.Set no_theory, " Completely deactivate theory reasoning"; "-age-bound", Arg.Set_int age_bound, " set the age limite bound"; "-greedy" , Arg.Set greedy, " use all available ground terms in instanciation"; "-nb-triggers" , Arg.Set_int nb_triggers, " number of redondant (multi)triggers (default: 2)"; "-triggers-var" , Arg.Set triggers_var , " allows variables as triggers"; "-rm-eq-existential", Arg.Set rm_eq_existential, " substitute a variable in an existential when an equality gives the value of the variable"; "-no-Ematching", Arg.Set no_Ematching, " disable matching modulo ground equalities"; "-no-backjumping", Arg.Set no_backjumping, " disable backjumping mechanism in DfsSAT"; "-no-NLA", Arg.Set no_NLA, " disable non-linear arithmetic reasoning (i.e. non-linear multplication, division and modulo on integers and rationals). Non-linear multiplication remains AC"; "-no-ac", Arg.Set no_ac, " Disable the AC theory of Associative and Commutative function symbols"; "-nocontracongru", Arg.Set nocontracongru, ""; "-term-like-pp", Arg.Set term_like_pp, " output semantic values as terms"; "-all-models", Arg.Set all_models, " experimental support for all models"; "-model", Arg.Set model, " experimental support for models on labeled terms"; "-complete-model", Arg.Set complete_model, " experimental support for complete model"; "-dinterpretation", Arg.Set debug_interpretation, " set debug flag for interpretation generatation"; "-interpretation", Arg.Set_int interpretation, " experimental support for counter-example generation. Possible values are 1, 2, or 3 to compute an interpretation before returning Unknown, before instantiation, or before every decision or instantiation. A negative value (-1, -2, or -3) will disable interpretation display. Note that -max-split limitation will be ignored in model generation phase"; "-proof", Arg.Set proof, " experimental support for succint proof"; "-debug-proof", Arg.Set debug_proof, " replay unsatisfiable core produced by -proof. This options implies -proof"; "-rules", Arg.String set_rules, "tr (tr in ) output rules used on stderr"; "-max-split", Arg.String set_max_split, (Format.sprintf " maximum size of case-split (default value : %s)" (Numbers.Q.to_string !max_split)); "-fm-cross-limit", Arg.String set_fm_cross_limit, (Format.sprintf " skip Fourier-Motzkin variables elimination steps that may produce a number of inequalities that is greater than the given limit (default value : %s). However, unit eliminations are always done" (Numbers.Q.to_string !fm_cross_limit)); "-case-split-policy", Arg.String set_case_split_policy_option, " case-split policy. Set the case-split policy to use. Possible values are: after-theory-assume (default), before-matching, after-matching" ; "-restricted", Arg.Set restricted, " restrict set of decision procedures (equality, arithmetic and AC)"; "-bottom-classes", Arg.Set bottom_classes, " show equivalence classes at each bottom of the sat"; "-replay", Arg.Set replay, " replay session saved in .agr"; "-replay-used-context", Arg.Set replay_used_context, " replay with axioms and predicates saved in .used file"; "-replay-all-used-context", Arg.Set replay_all_used_context, " replay with all axioms and predicates saved in .used files of the current directory"; "-save-used-context", Arg.Set save_used_context, " save used axioms and predicates in a .used file. This options implies -proof"; "-replay-satml-dfs", Arg.Set replay_satml_dfs, " debug option for the satML plugin. Replays proven (valid) goals (with generated ground instances) using Dfs-sat"; "-timelimit", Arg.Float (set_limit timelimit), "n set the time limit to n seconds (not supported on Windows)"; "-interpretation-timelimit", Arg.Float (set_limit interpretation_timelimit), "n set the time limit to n seconds for model generation (not supported on Windows). Default value is 1. sec"; "-sat-plugin" , Arg.String set_sat_plugin, " use the given SAT-solver instead of the default DFS-based SAT solver"; "-inequalities-plugin" , Arg.String set_inequalities_plugin, " use the given module to handle inequalities of linear arithmetic"; "-profiling", Arg.String parse_profiling, " activate the profiling module with the given frequency. Use Ctrl-C to switch between different views and \"Ctrl + AltGr + \\\" to exit."; "-profiling-plugin" , Arg.String set_profiling_plugin, " use the given profiling plugin"; "-cumulative-time-profiling", Arg.Set cumulative_time_profiling, " the time spent in called functions is also recorded in callers"; "-rwt", Arg.Set rewriting, " use rewriting instead of axiomatic approach"; "-normalize-instances" , Arg.Set normalize_instances, " normalize generated substitutions by matching w.r.t. the state of the theory. Default value is false. This means that only terms that are greater (w.r.t. depth) than the initial terms of the problem are normalized."; "-inst-after-bj", Arg.Set instantiate_after_backjump, " make a (normal) instantiation round after every backjump/backtrack" ; ] let spec = Arg.align spec let thread_yield = ref (fun () -> ()) let (timer_start : (Timers.ty_module -> Timers.ty_function -> unit) ref) = ref (fun _ _ -> ()) let (timer_pause : (Timers.ty_module -> Timers.ty_function -> unit) ref) = ref (fun _ _ -> ()) let (timeout : (unit -> unit) ref) = ref (fun () -> raise Util.Timeout) end let parse_args () = let ofile = ref None in let set_file s = if Filename.check_suffix s ".mlw" || Filename.check_suffix s ".why" || Filename.check_suffix s ".zip" then ofile := Some s else raise (Arg.Bad "no .mlw, .why or .zip extension") in Arg.parse M.spec set_file M.usage; match !ofile with | Some f -> M.file := f; M.session_file := (Filename.chop_extension f)^".agr"; M.used_context_file := (Filename.chop_extension f)^".used" | None -> () let set_file_for_js filename = M.file := filename; M.js_mode := true (* parse_args () should be called here because some choices during compilation depend on given options (e.g. dfs-sat *) let _ = parse_args () (** setter functions **********************************************************) (** setters for debug flags *) let set_debug b = M.debug := b let set_debug_cc b = M.debug_cc := b let set_debug_gc b = M.debug_gc := b let set_debug_use b = M.debug_use := b let set_debug_uf b = M.debug_uf := b let set_debug_fm b = M.debug_fm := b let set_debug_sum b = M.debug_sum := b let set_debug_arith b = M.debug_arith := b let set_debug_bitv b = M.debug_bitv := b let set_debug_ac b = M.debug_ac := b let set_debug_sat b = M.debug_sat := b let set_debug_sat_simple b = M.debug_sat_simple := b let set_debug_typing b = M.debug_typing := b let set_debug_constr b = M.debug_constr := b let set_debug_arrays b = M.debug_arrays := b let set_debug_types b = M.debug_types := b let set_debug_combine b = M.debug_combine := b let set_debug_proof b = M.debug_proof := b let set_debug_split b = M.debug_split := b let set_debug_matching i = M.debug_matching := i let set_debug_explanations b = M.debug_explanations := b (** additional setters *) let set_type_only b = M.type_only := b let set_parse_only b = M.parse_only := b let set_steps_bound b = M.steps_bound := b let set_age_bound b = M.age_bound := b let set_notriggers b = M.notriggers := b let set_verbose b = M.verbose := b let set_greedy b = M.greedy := b let set_triggers_var b = M.triggers_var := b let set_nb_triggers b = M.nb_triggers := b let set_rm_eq_existential b = M.rm_eq_existential := b let set_no_Ematching b = M.no_Ematching := b let set_nocontracongru b = M.nocontracongru := b let set_term_like_pp b = M.term_like_pp := b let set_all_models b = M.all_models := b let set_model b = M.model := b let set_complete_model b = M.complete_model := b let set_interpretation b = M.interpretation := b let set_max_split b = M.max_split := b let set_fm_cross_limit b = M.fm_cross_limit := b let set_rewriting b = M.rewriting := b let set_proof b = M.proof := b let set_rules b = M.rules := b let set_restricted b = M.restricted := b let set_bottom_classes b = M.bottom_classes := b let set_timelimit b = M.timelimit := b let set_model_timelimit b = M.timelimit := b let set_timers b = M.timers := b let set_profiling f b = M.profiling := b; M.profiling_period := if b then f else 0. let set_thread_yield f = M.thread_yield := f let set_timer_start f = assert (!M.timers || !M.profiling); M.timer_start := f let set_timer_pause f = assert (!M.timers || !M.profiling); M.timer_pause := f let set_timeout f = M.timeout := f let set_partial_bmodel b = M.partial_bmodel := b let set_save_used_context b = M.save_used_context := b (** getter functions **********************************************************) (** getters for debug flags *) let debug () = !M.debug let debug_warnings () = !M.debug_warnings let debug_cc () = !M.debug_cc let debug_gc () = !M.debug_gc let debug_use () = !M.debug_use let debug_uf () = !M.debug_uf let debug_fm () = !M.debug_fm let debug_sum () = !M.debug_sum let debug_arith () = !M.debug_arith let debug_bitv () = !M.debug_bitv let debug_ac () = !M.debug_ac let debug_sat () = !M.debug_sat let debug_sat_simple () = !M.debug_sat_simple let debug_typing () = !M.debug_typing let debug_constr () = !M.debug_constr let debug_arrays () = !M.debug_arrays let debug_types () = !M.debug_types let debug_combine () = !M.debug_combine let debug_proof () = !M.debug_proof let debug_split () = !M.debug_split let debug_matching () = !M.debug_matching let debug_explanations () = !M.debug_explanations (** additional getters *) let js_mode () = !M.js_mode let type_only () = !M.type_only let parse_only () = !M.parse_only let steps_bound () = !M.steps_bound let no_tcp () = !M.no_tcp let no_theory () = !M.no_theory let tighten_vars () = !M.tighten_vars let age_bound () = !M.age_bound let notriggers () = !M.notriggers let verbose () = !M.verbose let greedy () = !M.greedy let triggers_var () = !M.triggers_var let nb_triggers () = !M.nb_triggers let rm_eq_existential () = !M.rm_eq_existential let no_Ematching () = !M.no_Ematching let no_backjumping () = !M.no_backjumping let no_NLA () = !M.no_NLA let no_ac () = !M.no_ac let nocontracongru () = !M.nocontracongru let term_like_pp () = !M.term_like_pp let cumulative_time_profiling () = !M.cumulative_time_profiling let all_models () = !M.all_models let model () = !M.model || !M.complete_model let interpretation () = !M.interpretation let debug_interpretation () = !M.debug_interpretation let complete_model () = !M.complete_model let max_split () = !M.max_split let fm_cross_limit () = !M.fm_cross_limit let rewriting () = !M.rewriting let proof () = !M.proof || !M.save_used_context || !M.debug_proof let rules () = !M.rules let restricted () = !M.restricted let bottom_classes () = !M.bottom_classes let timelimit () = !M.timelimit let interpretation_timelimit () = !M.interpretation_timelimit let enable_assertions () = !M.enable_assertions let profiling () = !M.profiling let profiling_period () = !M.profiling_period let timers () = !M.timers || !M.profiling let case_split_policy () = !M.case_split_policy let instantiate_after_backjump () = !M.instantiate_after_backjump let replay () = !M.replay let replay_used_context () = !M.replay_used_context let replay_all_used_context () = !M.replay_all_used_context let save_used_context () = !M.save_used_context let replay_satml_dfs () = !M.replay_satml_dfs let get_file () = !M.file let get_session_file () = !M.session_file let get_used_context_file () = !M.used_context_file let sat_plugin () = !M.sat_plugin let inequalities_plugin () = !M.inequalities_plugin let profiling_plugin () = !M.profiling_plugin let normalize_instances () = !M.normalize_instances let partial_bmodel () = !M.partial_bmodel (** particular getters : functions that are immediately executed **************) let exec_thread_yield () = !M.thread_yield () let exec_timer_start kd msg = !M.timer_start kd msg let exec_timer_pause kd = !M.timer_pause kd let exec_timeout () = !M.timeout () let tool_req n msg = if rules () = n then Format.fprintf fmt "[rule] %s@." msg (** Simple Timer module **) module Time = struct let u = ref 0.0 let start () = u := MyUnix.cur_time() let value () = MyUnix.cur_time() -. !u let set_timeout tm = MyUnix.set_timeout tm let unset_timeout () = if timelimit() <> 0. then MyUnix.unset_timeout () end (** globals **) let cs_steps_cpt = ref 0 let cs_steps () = !cs_steps_cpt let incr_cs_steps () = incr cs_steps_cpt (** open Options in every module to hide polymorphic versions of Pervasives **) let (<>) (a: int) (b: int) = a <> b let (=) (a: int) (b: int) = a = b let (<) (a: int) (b: int) = a < b let (>) (a: int) (b: int) = a > b let (<=) (a: int) (b: int) = a <= b let (>=) (a: int) (b: int) = a >= b let compare (a: int) (b: int) = Pervasives.compare a b alt-ergo-1.30/src/util/hstring.mli0000644000175000001440000000376313014515065015451 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Hashcons type t = string hash_consed val make : string -> t val view : t -> string val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val empty : t val list_assoc : t -> (t * 'a) list -> 'a val fresh_string : unit -> string val is_fresh_string : string -> bool val is_fresh_skolem : string -> bool module Set : Set.S with type elt = t module Map : Map.S with type key = t alt-ergo-1.30/src/util/numbersInterface.mli0000644000175000001440000001052313014515065017257 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** Interface of Integers **) module type ZSig = sig type t val zero : t val one : t val m_one : t (* minus one *) val compare : t -> t -> int val compare_to_0 : t -> int val equal : t -> t -> bool val sign : t -> int val hash : t -> int val is_zero : t -> bool val is_one : t -> bool val is_m_one : t -> bool val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val div : t -> t -> t val rem : t -> t -> t val div_rem : t -> t -> t * t val minus : t -> t val abs : t -> t val my_gcd : t -> t -> t val my_lcm : t -> t -> t val max : t -> t -> t val from_int : int -> t val from_string : string -> t val to_string : t -> string (** convert to machine integer. returns None in case of overflow *) val to_machine_int : t -> int option val to_float : t -> float val fdiv : t -> t -> t val cdiv : t -> t -> t val power : t -> int -> t val print : Format.formatter -> t -> unit val shift_left: t -> int -> t (** Shifts left by (n:int >= 0) bits. This is the same as t * pow(2,n) *) val sqrt_rem: t -> (t * t) (** returns sqrt truncated with the remainder. It assumes that the argument is positive, otherwise, [Invalid_argument] is raised. *) (** [testbit z n] returns true iff the nth bit of z is set to 1. n is supposed to be positive *) val testbit: t -> int -> bool end (** Interface of Rationals **) module type QSig = sig module Z : ZSig type t exception Not_a_float val num : t -> Z.t val den : t -> Z.t val zero : t val one : t val m_one : t (* minus one *) val compare : t -> t -> int val compare_to_0 : t -> int val equal : t -> t -> bool val sign : t -> int val hash : t -> int val is_zero : t -> bool val is_one : t -> bool val is_m_one : t -> bool val is_int : t -> bool val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val div : t -> t -> t val minus : t -> t val abs : t -> t val min : t -> t -> t val max : t -> t -> t val inv : t -> t (* Euclidean division's remainder. Assumes that the arguments are in Z *) val modulo : t -> t -> t val from_float : float -> t val from_int : int -> t val from_z : Z.t -> t val from_zz: Z.t -> Z.t -> t val from_string : string -> t val to_float : t -> float val to_z : t -> Z.t (* Assumes that the argument is in Z *) val to_string : t -> string val print : Format.formatter -> t -> unit val power : t -> int -> t val floor : t -> t val ceiling : t -> t val truncate : t -> Z.t (** converts the argument to an integer by truncation. **) val mult_2exp: t -> int -> t (** multiplies the first argument by 2^(the second argument) *) val div_2exp: t -> int -> t (** divides the first argument by 2^(the second argument) *) end alt-ergo-1.30/src/util/profiling.ml0000644000175000001440000000073513014515065015607 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) include (val (Profiling_default.get_current ()) : Profiling_default.S) alt-ergo-1.30/src/util/profiling_default.ml0000644000175000001440000001031513014515065017306 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module type S = sig type t val init : unit -> unit val decision : int -> unit val assume : int -> unit val query : unit -> unit val instantiation : int -> unit val instances : 'a list -> unit val bool_conflict : unit -> unit val theory_conflict : unit -> unit (* each boolean is true for Boolean conflict and false for Theory conflict *) val bcp_conflict : bool -> bool -> unit (* the boolean is true for Boolean red/elim and false for Theory red/elim *) val red : bool -> unit val elim : bool -> unit (* reset decision and matching levels *) val reset_dlevel : int -> unit val reset_ilevel : int -> unit (* record the when axioms are instantiated. Bool tells whether the instance is kept or removed by the selector function *) val new_instance_of : string -> Loc.t -> bool -> unit val conflicting_instance : string -> Loc.t -> unit val register_produced_terms : string -> Loc.t -> Term.Set.t -> (* consumed *) Term.Set.t -> (* all terms of the instance *) Term.Set.t -> (* produced *) Term.Set.t -> (* produced that are new *) unit val print : bool -> int64 -> Timers.t -> Format.formatter -> unit val switch : unit -> unit end module M : S = struct let failure () = Format.eprintf "@.%s %s@.@." "Error: This module is not implemented! You may want to complile" "and load the plugin provided in non-free/profiler/ instead"; exit 1 type t = unit let init _ = () let query _ = failure () let assume _ = failure () let reset_dlevel _ = failure () let reset_ilevel _ = failure () let bcp_conflict _ = failure () let theory_conflict _ = failure () let bool_conflict _ = failure () let red _ = failure () let elim _ = failure () let instantiation _ = failure () let instances _ = failure () let decision _ = failure () let switch _ = failure () let new_instance_of _ _ = failure () let conflicting_instance _ _ = failure () let register_produced_terms _ = failure () let print_timers _ = failure () let print _ = failure () end let current = ref (module M : S) let initialized = ref false let set_current mdl = current := mdl let load_current_module () = match Options.profiling_plugin () with | "" -> if Options.profiling() then Format.eprintf "[Dynlink] Using the default profiler@." | path -> if Options.profiling() then Format.eprintf "[Dynlink] Loading the profiler in %s ...@." path; try MyDynlink.loadfile path; if Options.profiling() then Format.eprintf "Success !@.@." with | MyDynlink.Error m1 -> if Options.profiling() then begin Format.eprintf "[Dynlink] Loading the profiler in plugin \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; let prefixed_path = Format.sprintf "%s/%s" Config.pluginsdir path in if Options.profiling() then Format.eprintf "[Dynlink] Loading the profiler in %s ... with prefix %s@." path Config.pluginsdir; try MyDynlink.loadfile prefixed_path; if Options.profiling() then Format.eprintf "Success !@.@." with | MyDynlink.Error m2 -> if not (Options.profiling()) then begin Format.eprintf "[Dynlink] Loading the profiler in plugin \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; Format.eprintf "[Dynlink] Trying to load the plugin from \"%s\" failed too!@." prefixed_path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m2); exit 1 let get_current () = if Options.profiling () && not !initialized then begin load_current_module (); initialized := true; end; !current alt-ergo-1.30/src/util/myUnix.mli0000644000175000001440000000116013014515065015251 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** cur_time, provided by Unix or by Javascript depending on the compilation mode: for byte/opt or for javascript **) val cur_time : unit -> float val set_timeout : float -> unit val unset_timeout : unit -> unit alt-ergo-1.30/src/util/lists.ml0000644000175000001440000000155213014515065014752 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) let apply f l = let res, same = List.fold_left (fun (acc, same) a -> let b = f a in b :: acc, same && a == b )([], true) l in (if same then l else List.rev res), same let apply_right f l = let res, same = List.fold_left (fun (acc, same) (v, a) -> let b = f a in (v, b) :: acc, same && a == b )([], true) l in (if same then l else List.rev res), same let rrmap f l = List.rev (List.map f l) alt-ergo-1.30/src/util/hstring.ml0000644000175000001440000000521513014515065015272 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Hashcons open Options module S = Hashcons.Make_consed(struct include String let hash = Hashtbl.hash let equal = Pervasives.(=) end) type t = string Hashcons.hash_consed let make s = S.hashcons s let view s = s.node let equal s1 s2 = s1 == s2 let compare s1 s2 = compare s1.tag s2.tag let hash s = s.tag let empty = make "" let rec list_assoc x = function | [] -> raise Not_found | (y, v) :: l -> if equal x y then v else list_assoc x l let fresh_string = let cpt = ref 0 in fun () -> incr cpt; "!k" ^ (string_of_int !cpt) let is_fresh_string s = try s.[0] == '!' && s.[1] == 'k' with Invalid_argument s -> assert (String.compare s "index out of bounds" = 0); false let is_fresh_skolem s = try s.[0] == '!' && s.[1] == '?' with Invalid_argument s -> assert (String.compare s "index out of bounds" = 0); false module Arg = struct type t'= t type t = t' let compare = compare end module Set : Set.S with type elt = t = Set.Make(Arg) module Map : Map.S with type key = t = Map.Make(Arg) alt-ergo-1.30/src/util/myZip.ml0000644000175000001440000000212313014515065014717 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** A wrapper of the Zip module of CamlZip: we use Zip except when we want to generate the.js file for try-Alt-Ergo **) module ZipWrapper = struct include Zip let filename e = e.Zip.filename let is_directory e = e.Zip.is_directory end include ZipWrapper (* !! This commented code is used when compiling to javascript !! module DummyZip = struct type entry = unit type in_file = unit let s = "Zip module not available for your setting or has been disabled !" let open_in _ = failwith s let close_in _ = failwith s let entries _ = failwith s let read_entry _ _ = failwith s let filename _ = failwith s let is_directory _ = failwith s end include DummyZip *) alt-ergo-1.30/src/util/myDynlink.mli0000644000175000001440000000116113014515065015737 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** A wrapper of the Dynlink module: we use Dynlink except when we want to generate a static (native) binary **) type error exception Error of error val error_message : error -> string val loadfile : string -> unit alt-ergo-1.30/src/util/gc_debug.mli0000644000175000001440000000065413014515065015526 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (* empty interface *) alt-ergo-1.30/src/util/numsNumbers.ml0000644000175000001440000001566613014515065016145 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** Integers implementation. Based on Zarith's integers **) module Z : NumbersInterface.ZSig with type t = Big_int.big_int = struct open Big_int type t = big_int let zero = zero_big_int let one = unit_big_int let m_one = minus_big_int one let compare a b = compare_big_int a b let compare_to_0 a = sign_big_int a let equal a b = eq_big_int a b let is_zero t = compare_to_0 t = 0 let is_one t = equal t one let is_m_one t = equal t m_one let sign t = sign_big_int t let hash t = Hashtbl.hash t let add a b = add_big_int a b let mult a b = mult_big_int a b let abs t = abs_big_int t let sub a b = sub_big_int a b let minus t = minus_big_int t let div a b = assert (not (is_zero b)); div_big_int a b let max a b = max_big_int a b let to_string t = string_of_big_int t let from_string s = big_int_of_string s let from_int n = big_int_of_int n let rem a b = assert (not (is_zero b)); mod_big_int a b let div_rem a b = assert (not (is_zero b)); quomod_big_int a b let print fmt t = Format.fprintf fmt "%s" (to_string t) let my_gcd a b = if is_zero a then b else if is_zero b then a else gcd_big_int a b let my_lcm a b = try div (mult a b) (my_gcd a b) with e -> Format.printf "my_lcm %a %a failed with:@.%s@." print a print b (Printexc.to_string e); assert false let to_float t = float_of_big_int t let to_machine_int t = try Some (Big_int.int_of_big_int t) with _ -> None let fdiv a b = assert (not (is_zero b)); let open Num in try let n1 = num_of_big_int a in let n2 = num_of_big_int b in let nm = div_num n1 n2 in big_int_of_num (floor_num nm) with e -> Format.printf "fdiv %a %a failed with:@.%s@." print a print b (Printexc.to_string e); assert false let cdiv a b = assert (not (is_zero b)); let open Num in try let n1 = num_of_big_int a in let n2 = num_of_big_int b in let nm = div_num n1 n2 in big_int_of_num (ceiling_num nm) with e -> Format.printf "cdiv %a %a failed with:@.%s@." print a print b (Printexc.to_string e); assert false let power a n = assert (n>=0); power_big_int_positive_int a n (* Shifts left by (n:int >= 0) bits. This is the same as t * pow(2,n) *) let shift_left = shift_left_big_int (* returns sqrt truncated with the remainder. It assumes that the argument is positive, otherwise, [Invalid_argument] is raised. *) let sqrt_rem t = let sq = sqrt_big_int t in sq, sub t (mult sq sq) let testbit z n = assert (n >= 0); is_one (extract_big_int z n 1) end (** Rationals implementation. Based on Zarith's rationals **) module Q : NumbersInterface.QSig with module Z = Z = struct module Z = Z exception Not_a_float open Num type t = num let zero = Int 0 let one = Int 1 let m_one = Int (-1) let of_int n = Int n let compare_to_0 n = sign_num n let is_zero n = compare_to_0 n = 0 let equal a b = a =/ b let is_one n = equal one n let is_m_one n = equal m_one n let ceiling = ceiling_num let floor = floor_num let is_int = is_integer_num let abs = abs_num let power a n = if n = 0 then one (* 0 ^ 0 = 1, undefined in mathematics*) else match a with | Int 1 -> one | Int 0 -> zero | Int (-1) -> if n mod 2 = 0 then one else m_one | _ -> power_num a (Int n) let modulo = mod_num let div a b = assert (not (is_zero b)); div_num a b let mult = mult_num let sub = sub_num let add = add_num let minus = minus_num let sign = sign_num let compare = compare_num let equal a b = a =/ b let to_string = string_of_num let from_string = num_of_string let to_float = float_of_num let to_z = big_int_of_num let from_z = num_of_big_int let from_int i = num_of_int i let den = function | Int _ | Big_int _ -> Big_int.unit_big_int | Ratio rat -> Ratio.denominator_ratio rat let num = function | Int i -> Big_int.big_int_of_int i | Big_int b -> b | Ratio rat -> Ratio.numerator_ratio rat let from_float x = if x = infinity || x = neg_infinity then raise Not_a_float; let (f, n) = frexp x in let z = Big_int.big_int_of_string (Int64.to_string (Int64.of_float (f *. 2. ** 52.))) in let factor = power (of_int 2) (n - 52) in mult (from_z z) factor let hash v = match v with | Int i -> i | Big_int b -> Hashtbl.hash b | Ratio rat -> Hashtbl.hash (Ratio.normalize_ratio rat) let print fmt q = Format.fprintf fmt "%s" (to_string q) let min t1 t2 = min_num t1 t2 let max t1 t2 = max_num t1 t2 let inv t = if Z.is_zero (num t) then raise Division_by_zero; one // t let from_zz z1 z2 = Big_int z1 // Big_int z2 (******** comparer avec l'implem de Alain de of_float let ratio_of_float f = Ratio.ratio_of_string (string_of_float f) let num_of_float f = num_of_ratio (ratio_of_float f) let of_float x = let res = of_float x in let z = num_of_float x in assert (res =/ z); res ********) let truncate t = let res = integer_num t in assert (compare (abs res) (abs t) <= 0); match res with | Int i -> Big_int.big_int_of_int i | Big_int b -> b | Ratio rat -> assert false let mult_2exp t n = mult t (power (Int 2) n) let div_2exp t n = div t (power (Int 2) n) end alt-ergo-1.30/src/util/profiling_default.mli0000644000175000001440000000376213014515065017467 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module type S = sig type t val init : unit -> unit val decision : int -> unit val assume : int -> unit val query : unit -> unit val instantiation : int -> unit val instances : 'a list -> unit val bool_conflict : unit -> unit val theory_conflict : unit -> unit (* each boolean is true for Boolean conflict and false for Theory conflict *) val bcp_conflict : bool -> bool -> unit (* the boolean is true for Boolean red/elim and false for Theory red/elim *) val red : bool -> unit val elim : bool -> unit (* reset decision and matching levels *) val reset_dlevel : int -> unit val reset_ilevel : int -> unit (* record the when axioms are instantiated. Bool tells whether the instance is keeped or removed by the selector function *) val new_instance_of : string -> Loc.t -> bool -> unit val conflicting_instance : string -> Loc.t -> unit val register_produced_terms : string -> Loc.t -> Term.Set.t -> (* consumed *) Term.Set.t -> (* all terms of the instance *) Term.Set.t -> (* produced *) Term.Set.t -> (* produced that are new *) unit val print : bool -> int64 -> Timers.t -> Format.formatter -> unit val switch : unit -> unit end val get_current : unit -> (module S) (** returns the current activated profiler. The default value is an internal module Profiling_default.M When the selected profiler is an external plugin, the first call of this function will attemp to dynamically load it **) val set_current : (module S) -> unit (** sets a new profiler. This function is intended to be used by dynamically loaded plugins **) alt-ergo-1.30/src/util/emap.ml0000644000175000001440000002570513014515065014544 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (******************************************************************************) (***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type key type +'a t val empty: 'a t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val for_all: (key -> 'a -> bool) -> 'a t -> bool val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal: 'a t -> int val height: 'a t -> int val bindings: 'a t -> (key * 'a) list val min_binding: 'a t -> (key * 'a) val max_binding: 'a t -> (key * 'a) val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end module Make(Ord: OrderedType) = struct type key = Ord.t type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int let height = function Empty -> 0 | Node(_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let singleton x d = Node(Empty, x, d, Empty, 1) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let empty = Empty let is_empty = function Empty -> true | _ -> false let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) -> let c = Ord.compare x v in if c = 0 then Node(l, x, data, r, h) else if c < 0 then bal (add x data l) v d r else bal l v d (add x data r) let rec find x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec mem x = function Empty -> false | Node(l, v, d, r, _) -> let c = Ord.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec min_binding = function Empty -> raise Not_found | Node(Empty, x, d, r, _) -> (x, d) | Node(l, x, d, r, _) -> min_binding l let rec max_binding = function Empty -> raise Not_found | Node(l, x, d, Empty, _) -> (x, d) | Node(l, x, d, r, _) -> max_binding r let rec remove_min_binding = function Empty -> invalid_arg "Map.remove_min_elt" | Node(Empty, x, d, r, _) -> r | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r let merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in bal t1 x d (remove_min_binding t2) let rec remove x = function Empty -> Empty | Node(l, v, d, r, h) -> let c = Ord.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v d r else bal l v d (remove x r) let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = map f l in let d' = f d in let r' = map f r in Node(l', v, d', r', h) let rec mapi f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = mapi f l in let d' = f v d in let r' = mapi f r in Node(l', v, d', r', h) let rec fold f m accu = match m with Empty -> accu | Node(l, v, d, r, _) -> fold f r (f v d (fold f l accu)) let rec for_all p = function Empty -> true | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r let rec exists p = function Empty -> false | Node(l, v, d, r, _) -> p v d || exists p l || exists p r (* Beware: those two functions assume that the added k is *strictly* smaller (or bigger) than all the present keys in the tree; it does not test for equality with the current min (or max) key. Indeed, they are only used during the "join" operation which respects this precondition. *) let rec add_min_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, h) -> bal (add_min_binding k v l) x d r let rec add_max_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, h) -> bal l x d (add_max_binding k v r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v d r = match (l, r) with (Empty, _) -> add_min_binding v d r | (_, Empty) -> add_max_binding v d l | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> if lh > rh + 2 then bal ll lv ld (join lr v d r) else if rh > lh + 2 then bal (join l v d rl) rv rd rr else create l v d r (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in join t1 x d (remove_min_binding t2) let concat_or_join t1 v d t2 = match d with | Some d -> join t1 v d t2 | None -> concat t1 t2 let rec split x = function Empty -> (Empty, None, Empty) | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then (l, Some d, r) else if c < 0 then let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) else let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) let rec merge f s1 s2 = match (s1, s2) with (Empty, Empty) -> Empty | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> let (l2, d2, r2) = split v1 s2 in concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) | (_, Node (l2, v2, d2, r2, h2)) -> let (l1, d1, r1) = split v2 s1 in concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) | _ -> assert false let rec filter p = function Empty -> Empty | Node(l, v, d, r, _) -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pvd = p v d in let r' = filter p r in if pvd then join l' v d r' else concat l' r' let rec partition p = function Empty -> (Empty, Empty) | Node(l, v, d, r, _) -> (* call [p] in the expected left-to-right order *) let (lt, lf) = partition p l in let pvd = p v d in let (rt, rf) = partition p r in if pvd then (join lt v d rt, concat lf rf) else (concat lt rt, join lf v d rf) type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration let rec cons_enum m e = match m with Empty -> e | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) let compare cmp m1 m2 = let rec compare_aux e1 e2 = match (e1, e2) with (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else let c = cmp d1 d2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) in compare_aux (cons_enum m1 End) (cons_enum m2 End) let equal cmp m1 m2 = let rec equal_aux e1 e2 = match (e1, e2) with (End, End) -> true | (End, _) -> false | (_, End) -> false | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> Ord.compare v1 v2 = 0 && cmp d1 d2 && equal_aux (cons_enum r1 e1) (cons_enum r2 e2) in equal_aux (cons_enum m1 End) (cons_enum m2 End) let rec cardinal = function Empty -> 0 | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r let rec bindings_aux accu = function Empty -> accu | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let choose = min_binding end alt-ergo-1.30/src/util/version.mli0000644000175000001440000000074113014515065015451 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) val version : string val release_commit : string val release_date : string alt-ergo-1.30/src/util/myDynlink.ml0000644000175000001440000000123313014515065015566 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** A wrapper of the Dynlink module: we use Dynlink except when we want to generate a static (native) binary **) module DummyDL = struct type error = string exception Error of error let error_message s = s let loadfile s = () end include Dynlink alt-ergo-1.30/src/util/profiling.mli0000644000175000001440000000066213014515065015757 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) include Profiling_default.S alt-ergo-1.30/src/util/emap.mli0000644000175000001440000001756613014515065014723 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (******************************************************************************) (***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (** Association tables over ordered types. This module implements applicative association tables, also known as finite maps or dictionaries, given a total ordering function over the keys. All operations over maps are purely applicative (no side-effects). The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. *) module type OrderedType = sig type t (** The type of the map keys. *) val compare : t -> t -> int (** A total ordering function over the keys. This is a two-argument function [f] such that [f e1 e2] is zero if the keys [e1] and [e2] are equal, [f e1 e2] is strictly negative if [e1] is smaller than [e2], and [f e1 e2] is strictly positive if [e1] is greater than [e2]. Example: a suitable ordering function is the generic structural comparison function {!Pervasives.compare}. *) end (** Input signature of the functor {!Map.Make}. *) module type S = sig type key (** The type of the map keys. *) type (+'a) t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t (** The empty map. *) val is_empty: 'a t -> bool (** Test whether a map is empty or not. *) val mem: key -> 'a t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val add: key -> 'a -> 'a t -> 'a t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) val singleton: key -> 'a -> 'a t (** [singleton x y] returns the one-element map that contains a binding [y] for [x]. @since 3.12.0 *) val remove: key -> 'a t -> 'a t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. @since 3.12.0 *) val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val iter: (key -> 'a -> unit) -> 'a t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in increasing order), and [d1 ... dN] are the associated data. *) val for_all: (key -> 'a -> bool) -> 'a t -> bool (** [for_all p m] checks if all the bindings of the map satisfy the predicate [p]. @since 3.12.0 *) val exists: (key -> 'a -> bool) -> 'a t -> bool (** [exists p m] checks if at least one binding of the map satisfy the predicate [p]. @since 3.12.0 *) val filter: (key -> 'a -> bool) -> 'a t -> 'a t (** [filter p m] returns the map with all the bindings in [m] that satisfy predicate [p]. @since 3.12.0 *) val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. @since 3.12.0 *) val cardinal: 'a t -> int (** Return the number of bindings of a map. @since 3.12.0 *) (** Return the height of the tree encodin the map. NOTE THAT: two maps that are equal may have a different height. @since now *) val height: 'a t -> int val bindings: 'a t -> (key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Map.Make}. @since 3.12.0 *) val min_binding: 'a t -> (key * 'a) (** Return the smallest binding of the given map (with respect to the [Ord.compare] ordering), or raise [Not_found] if the map is empty. @since 3.12.0 *) val max_binding: 'a t -> (key * 'a) (** Same as {!Map.S.min_binding}, but returns the largest binding of the given map. @since 3.12.0 *) val choose: 'a t -> (key * 'a) (** Return one binding of the given map, or raise [Not_found] if the map is empty. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 3.12.0 *) val split: key -> 'a t -> 'a t * 'a option * 'a t (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. @since 3.12.0 *) val find: key -> 'a t -> 'a (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!Map.S.map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) end (** Output signature of the functor {!Map.Make}. *) module Make (Ord : OrderedType) : S with type key = Ord.t (** Functor building an implementation of the map structure given a totally ordered type. *) alt-ergo-1.30/src/util/numbers.mli0000644000175000001440000000440313014515065015436 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** Integers implementation. **) module Z : NumbersInterface.ZSig (** Rationals implementation. **) module Q : sig include NumbersInterface.QSig with module Z = Z (* computing root and sqrt by default and "by excess". The given rational is supposed to be positive. The integer provided for root_xxx is also supposed to be positive. Computations use floats. None is returned in case of failure. sqrt_xxx versions are more accurate and faster than their equivalent root_xxx when the integer is 2*) val root_default : t -> int -> t option val root_excess : t -> int -> t option val sqrt_default : t -> t option val sqrt_excess : t -> t option end alt-ergo-1.30/src/util/hashcons.ml0000644000175000001440000000615313014515065015424 0ustar rtusers(**************************************************************************) (* *) (* Copyright (C) 2010- *) (* François Bobot *) (* Jean-Christophe Filliâtre *) (* Claude Marché *) (* Andrei Paskevich *) (* *) (* This software is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License version 2.1, with the special exception on linking *) (* described in file LICENSE. *) (* *) (* This software is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (**************************************************************************) (*s Hash tables for hash-consing. (Some code is borrowed from the ocaml standard library, which is copyright 1996 INRIA.) *) open Options module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int val tag : int -> t -> t end module type S = sig type t val hashcons : t -> t val iter : (t -> unit) -> unit val stats : unit -> int * int * int * int * int * int end module Make(H : HashedType) : (S with type t = H.t) = struct type t = H.t module WH = Weak.Make (H) let next_tag = ref 0 let htable = WH.create 5003 let hashcons d = let d = H.tag !next_tag d in let o = WH.merge htable d in if o == d then incr next_tag; o let iter f = WH.iter f htable let stats () = WH.stats htable end let combine acc n = n * 65599 + acc let combine2 acc n1 n2 = combine acc (combine n1 n2) let combine3 acc n1 n2 n3 = combine acc (combine n1 (combine n2 n3)) let combine_list f = List.fold_left (fun acc x -> combine acc (f x)) let combine_option h = function None -> 0 | Some s -> (h s) + 1 let combine_pair h1 h2 (a1,a2) = combine (h1 a1) (h2 a2) type 'a hash_consed = { tag : int; node : 'a } module type HashedType_consed = sig type t val equal : t -> t -> bool val hash : t -> int end module type S_consed = sig type key val hashcons : key -> key hash_consed val iter : (key hash_consed -> unit) -> unit val stats : unit -> int * int * int * int * int * int end module Make_consed(H : HashedType_consed) : (S_consed with type key = H.t) = struct module M = Make(struct type t = H.t hash_consed let hash x = H.hash x.node let equal x y = H.equal x.node y.node let tag i x = {x with tag = i} end) include M type key = H.t let hashcons x = M.hashcons {tag = -1; node = x} end alt-ergo-1.30/src/util/numsNumbers.mli0000644000175000001440000000345313014515065016305 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** Integers implementation. Based on big_int **) module Z : NumbersInterface.ZSig with type t = Big_int.big_int (** Rationals implementation. Based on nums **) module Q : NumbersInterface.QSig with module Z = Z alt-ergo-1.30/src/util/util.mli0000644000175000001440000000221313014515065014735 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) exception Timeout module MI : Map.S with type key = int (** Different values for -case-split-policy option: -after-theory-assume (default value): after assuming facts in theory by the SAT -before-matching: just before performing a matching round -after-matching: just after performing a matching round **) type case_split_policy = | AfterTheoryAssume (* default *) | BeforeMatching | AfterMatching (* (** This function is intended to be used with Map.merge in order to perform a union of two maps. The first argument is an equality function used to assert that bindings present in boths maps have the same value **) val map_merge_is_union : ('a -> 'a -> bool) -> 'b -> ('a * int) option -> ('a * int) option -> ('a * int) option *) alt-ergo-1.30/src/util/gc_debug.ml0000644000175000001440000000341613014515065015354 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format open Gc (* major_collections; (* num of completed major collection cycles *) minor_collections; (* num of minor collections *) stack_size; (* current size of the stack, in word *) heap_words; (* tot size of the major heap *) top_heap_words; (* Max size reached by major heap *) minor_words; (* num of alloc words in minor heap since beginning *) major_words; (* num of alloc words in major heap, since beginning *) *) let () = if debug_gc() then begin let tmp = ref (quick_stat ()) in ignore (create_alarm (fun () -> let e = quick_stat () in let d = !tmp in fprintf fmt "[GC infos]==========================================@."; fprintf fmt "[major collections] %d th@." e.major_collections; fprintf fmt "[minor collections] %d th@." e.minor_collections; fprintf fmt "[stack used] %d words@." e.stack_size; fprintf fmt "[size of major heap] %d words@." e.heap_words; fprintf fmt "[max size major heap] %d words@." e.top_heap_words; fprintf fmt "[major words diff] %0.f Kwords@." ((e.major_words -. d.major_words) /. 1000.); fprintf fmt "[minor words diff] %0.f Kwords@." ((e.minor_words -. d.minor_words) /. 1000.); tmp := e ) ) end alt-ergo-1.30/src/util/timers.ml0000644000175000001440000001723213014515065015121 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format type ty_module = | M_None | M_Typing | M_Sat | M_Match | M_CC | M_UF | M_Arith | M_Arrays | M_Sum | M_Records | M_AC | M_Formula | M_Literal | M_Term | M_Triggers let mtag k = match k with | M_None -> 0 | M_Typing -> 1 | M_Sat -> 2 | M_Match -> 3 | M_CC -> 4 | M_UF -> 5 | M_Arith -> 6 | M_Arrays -> 7 | M_Sum -> 8 | M_Records-> 9 | M_AC -> 10 | M_Formula-> 11 | M_Literal-> 12 | M_Term -> 13 | M_Triggers->14 let nb_mtag = 15 type ty_function = | F_add | F_add_lemma | F_add_predicate | F_add_terms | F_are_equal | F_assume | F_class_of | F_leaves | F_make | F_m_lemmas | F_m_predicates | F_query | F_solve | F_subst | F_union | F_unsat | F_none | F_new_facts | F_apply_subst | F_instantiate let ftag f = match f with | F_add -> 0 | F_add_lemma -> 1 | F_assume -> 2 | F_class_of -> 3 | F_leaves -> 4 | F_make -> 5 | F_m_lemmas -> 6 | F_m_predicates -> 7 | F_query -> 8 | F_solve -> 9 | F_subst -> 10 | F_union -> 11 | F_unsat -> 12 | F_add_predicate -> 13 | F_add_terms -> 14 | F_are_equal -> 15 | F_none -> 16 | F_new_facts -> 17 | F_apply_subst -> 18 | F_instantiate -> 19 let nb_ftag = 20 let string_of_ty_module k = match k with | M_None -> "None" | M_Typing -> "Typing" | M_Sat -> "Sat" | M_Match -> "Match" | M_CC -> "CC" | M_UF -> "UF" | M_Arith -> "Arith" | M_Arrays -> "Arrays" | M_Sum -> "Sum" | M_Records-> "Records" | M_AC -> "AC" | M_Formula-> "Formula" | M_Literal-> "Literal" | M_Term -> "Term" | M_Triggers->"Triggers" let string_of_ty_function f = match f with | F_add -> "add" | F_add_lemma -> "add_lemma" | F_assume -> "assume" | F_class_of -> "class_of" | F_leaves -> "leaves" | F_make -> "make" | F_m_lemmas -> "m_lemmas" | F_m_predicates -> "m_predicates" | F_query -> "query" | F_solve -> "solve" | F_subst -> "subst" | F_union -> "union" | F_unsat -> "unsat" | F_add_predicate -> "add_predicate" | F_add_terms -> "add_terms" | F_are_equal -> "are_equal" | F_none -> "none" | F_new_facts -> "new_facts" | F_apply_subst -> "apply_subst" | F_instantiate -> "instantiate" type t = { (* current time *) mutable cur_u : float; (* current activated (module x function) for time profiling *) mutable cur_t : (ty_module * ty_function * int); (* stack of suspended (module x function)s callers *) mutable stack : (ty_module * ty_function * int) list; (* table of timers for each combination "" *) z : (float array) array; (*h:(ty_module, float ref) Hashtbl.t;*) } let cpt_id = ref 0 let fresh_id () = incr cpt_id; !cpt_id (** return a new empty env **) let empty () = { cur_t = (M_None, F_none, 0); cur_u = 0.0; stack = []; z = Array.init nb_mtag (fun _ -> Array.make nb_ftag 0.); } (** reset the references of the given env to empty **) let reset env = for i = 0 to nb_mtag - 1 do let a = env.z.(i) in for j = 0 to nb_ftag - 1 do a.(j) <- 0. done done; env.cur_t <- (M_None, F_none, 0); env.cur_u <- 0.0; env.stack <- []; cpt_id := 0 let accumulate env cur m f = let mt = mtag m in let ft = ftag f in env.z.(mt).(ft) <- env.z.(mt).(ft) +. (cur -. env.cur_u) let accumulate_cumulative_mode name env m f cur = (* currently disable because we have a circular dependency between Options and Timers *) () (* if Options.cumulative_time_profiling() then if Options.debug() then eprintf "@.%s time of %s , %s@." name (string_of_ty_module m) (string_of_ty_function f); List.iter (fun (m, f, id) -> if Options.debug() then eprintf " also update time of %s , %s@." (string_of_ty_module m) (string_of_ty_function f); accumulate env cur m f )env.stack *) (** save the current timer and start the timer m x f **) let start env m f = let cur = MyUnix.cur_time() in accumulate_cumulative_mode "start" env m f cur; begin match env.cur_t with | (M_None, _, _) -> () | kd -> accumulate env cur m f; env.stack <- kd :: env.stack end; env.cur_t <- (m, f, fresh_id()); env.cur_u <- cur (** pause the timer "m x f" and restore the former timer **) let pause env m f = let cur = MyUnix.cur_time() in accumulate_cumulative_mode "pause" env m f cur; accumulate env cur m f; env.cur_u <- cur; match env.stack with | [] -> env.cur_t <- (M_None, F_none, 0) | kd::st -> env.cur_t <- kd; env.stack <- st (** update the value of the current timer **) let update env = let cur = MyUnix.cur_time() in let m, f, id = env.cur_t in accumulate_cumulative_mode "update" env m f cur; accumulate env cur m f; env.cur_u <- cur (** get the value of the timer "m x f" **) let get_value env m f = env.z.(mtag m).(ftag f) (** get the sum of the "ty_function" timers for the given "ty_module" **) let get_sum env m = let cpt = ref 0. in Array.iter (fun v -> cpt := !cpt +. v) env.z.(mtag m); !cpt let current_timer env = env.cur_t let get_stack env = env.stack let get_timers_array env = env.z let all_functions = let l = [ F_add; F_add_lemma; F_add_predicate; F_add_terms; F_are_equal; F_assume; F_class_of; F_leaves; F_make; F_m_lemmas; F_m_predicates; F_query; F_solve; F_subst; F_union; F_unsat; F_none; F_new_facts; F_apply_subst; F_instantiate; ] in assert (List.length l = nb_ftag); l let all_modules = let l = [ M_None; M_Typing; M_Sat; M_Match; M_CC; M_UF; M_Arith; M_Arrays; M_Sum; M_Records; M_AC; M_Formula; M_Literal; M_Term; M_Triggers; ] in assert (List.length l = nb_mtag); l alt-ergo-1.30/src/util/numbers.ml0000644000175000001440000000736513014515065015277 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module MyZarith = ZarithNumbers module MyNums = NumsNumbers module Z = MyZarith.Z module Q = struct include MyZarith.Q let two = from_int 2 let root_num q n = assert (n >= 0); let sgn = sign q in assert (sgn >= 0); if n = 1 then Some q else if sgn = 0 then Some zero else let v = to_float q in let w = if Pervasives.(<) v min_float then min_float else if Pervasives.(>) v max_float then max_float else v in let flt = if n = 2 then sqrt w else w ** (1. /. float n) in match classify_float flt with | FP_normal | FP_subnormal | FP_zero -> Some (from_float flt) | FP_infinite | FP_nan -> None let unaccurate_root_default q n = match root_num q n with | None -> None | (Some s) as res -> let d = sub q (power s n) in if sign d >= 0 then res else Some (div q (power s (n - 1))) let unaccurate_root_excess q n = match root_num q n with | None -> None | Some s as res -> let d = sub q (power s n) in if sign d <= 0 then res else Some (div q (power s (n - 1))) let accurate_root_default q n = let dd = unaccurate_root_default q n in let ee = unaccurate_root_excess q n in match dd, ee with | None, _ | _ , None -> dd | Some d, Some e -> let cand = div (add d e) two in if MyZarith.Q.compare (power cand n) q <= 0 then Some cand else dd let accurate_root_excess q n = let dd = unaccurate_root_default q n in let ee = unaccurate_root_excess q n in match dd, ee with | None, _ | _ , None -> ee | Some d, Some e -> let cand = div (add d e) two in if MyZarith.Q.compare (power cand n) q >= 0 then Some cand else ee let sqrt_excess q = match root_num q 2 with | None -> None | Some s -> if not (is_zero s) then Some (div (add s (div q s)) two) else accurate_root_default q 2 let sqrt_default q = match sqrt_excess q with | None -> None | Some s -> if not (is_zero s) then Some (div q s) else accurate_root_excess q 2 let root_default = accurate_root_default let root_excess = accurate_root_excess end alt-ergo-1.30/src/util/loc.mli0000644000175000001440000000325513014515065014544 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type t = Lexing.position * Lexing.position val report : Format.formatter -> t -> unit alt-ergo-1.30/src/util/loc.ml0000644000175000001440000000356513014515065014377 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Lexing type t = Lexing.position * Lexing.position let report fmt (b,e) = let l = b.pos_lnum in let fc = b.pos_cnum - b.pos_bol + 1 in let lc = e.pos_cnum - b.pos_bol + 1 in fprintf fmt "File \"%s\", line %d, characters %d-%d:" (Options.get_file()) l fc lc alt-ergo-1.30/src/util/zarithNumbers.ml0000644000175000001440000001300513014515065016445 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** Integers implementation. Based on Zarith's integers **) module Z : NumbersInterface.ZSig with type t = Z.t = struct type t = Z.t let zero = Z.zero let one = Z.one let m_one = Z.minus_one let compare a b = Z.compare a b let compare_to_0 t = Z.sign t let equal a b = Z.equal a b let sign t = Z.sign t let hash t = Z.hash t let is_zero t = compare_to_0 t = 0 let is_one t = equal t one let is_m_one t = equal t m_one let add a b = Z.add a b let sub a b = Z.sub a b let mult a b = Z.mul a b let div a b = assert (not (is_zero b)); Z.div a b let rem a b = assert (not (is_zero b)); Z.rem a b let div_rem a b = assert (not (is_zero b)); Z.div_rem a b let minus t = Z.neg t let abs t = Z.abs t let max t1 t2 = Z.max t1 t2 let from_int n = Z.of_int n let from_string s = Z.of_string s let to_string t = Z.to_string t let print fmt z = Format.fprintf fmt "%s" (to_string z) let my_gcd a b = if is_zero a then b else if is_zero b then a else Z.gcd a b let my_lcm a b = try let res1 = Z.lcm a b in assert (equal res1 (div (mult a b) (my_gcd a b))); res1 with Division_by_zero -> assert false let to_machine_int t = try Some (Z.to_int t) with Z.Overflow -> None (* These functuons are not exported, but they are used by module Q below *) let to_float z = Z.to_float z let fdiv z1 z2 = assert (not (is_zero z2)); Z.fdiv z1 z2 let cdiv z1 z2 = assert (not (is_zero z2)); Z.cdiv z1 z2 let power z n = assert (n >= 0); Z.pow z n (* Shifts left by (n:int >= 0) bits. This is the same as t * pow(2,n) *) let shift_left = Z.shift_left (* returns sqrt truncated with the remainder. It assumes that the argument is positive, otherwise, [Invalid_argument] is raised. *) let sqrt_rem = Z.sqrt_rem let testbit z n = assert (n >= 0); Z.testbit z n end (** Rationals implementation. Based on Zarith's rationals **) module Q : NumbersInterface.QSig with module Z = Z = struct module Z = Z exception Not_a_float type t = Q.t let num t = Q.num t let den t = Q.den t let zero = Q.zero let one = Q.one let m_one = Q.minus_one let compare t1 t2 = Q.compare t1 t2 let compare_to_0 t = Q.sign t let equal t1 t2 = Q.equal t1 t2 let sign t = Q.sign t let hash t = 13 * Z.hash (num t) + 23 * Z.hash (den t) let is_zero t = compare_to_0 t = 0 let is_one t = equal t one let is_m_one t = equal t m_one let is_int t = Z.is_one (den t) let add t1 t2 = Q.add t1 t2 let sub t1 t2 = Q.sub t1 t2 let mult t1 t2 = Q.mul t1 t2 let div t1 t2 = assert (not (is_zero t2)); Q.div t1 t2 let minus t = Q.neg t let abs t = Q.abs t let min t1 t2 = Q.min t1 t2 let max t1 t2 = Q.max t1 t2 let inv t = if Z.is_zero (num t) then raise Division_by_zero; Q.inv t let from_int n = Q.of_int n let from_z z = Q.make z Z.one let from_zz z1 z2 = Q.make z1 z2 let from_string s = Q.of_string s let from_float f = if f = infinity || f = neg_infinity then raise Not_a_float; Q.of_float f let to_string t = Q.to_string t let to_z q = assert (is_int q); num q let to_float t = (Z.to_float (num t)) /. (Z.to_float (den t)) let print fmt q = Format.fprintf fmt "%s" (to_string q) let floor t = from_z (Z.fdiv (num t) (den t)) let ceiling t = from_z (Z.cdiv (num t) (den t)) let power t n = let abs_n = Pervasives.abs n in let num_pow = Z.power (num t) abs_n in let den_pow = Z.power (den t) abs_n in if n >= 0 then from_zz num_pow den_pow else from_zz den_pow num_pow let modulo t1 t2 = assert (is_int t1 && is_int t2); from_zz (Z.rem (num t1) (num t2)) Z.one (* converts the argument to an integer by truncation. *) let truncate = Q.to_bigint let mult_2exp = Q.mul_2exp let div_2exp = Q.div_2exp end alt-ergo-1.30/src/util/options.mli0000644000175000001440000001663713014515065015472 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) val fmt : Format.formatter (** setter functions **********************************************************) (** setters for debug flags *) val set_debug : bool -> unit val set_debug_cc : bool -> unit val set_debug_gc : bool -> unit val set_debug_use : bool -> unit val set_debug_uf : bool -> unit val set_debug_fm : bool -> unit val set_debug_sum : bool -> unit val set_debug_arith : bool -> unit val set_debug_bitv : bool -> unit val set_debug_ac : bool -> unit val set_debug_sat : bool -> unit val set_debug_sat_simple : bool -> unit val set_debug_typing : bool -> unit val set_debug_constr : bool -> unit val set_debug_arrays : bool -> unit val set_debug_types : bool -> unit val set_debug_combine : bool -> unit val set_debug_proof : bool -> unit val set_debug_split : bool -> unit val set_debug_matching : int -> unit val set_debug_explanations : bool -> unit val set_timers : bool -> unit val set_profiling : float -> bool -> unit (** additional setters *) val set_type_only : bool -> unit val set_parse_only : bool -> unit val set_verbose : bool -> unit val set_steps_bound : int -> unit val set_age_bound : int -> unit val set_notriggers : bool -> unit val set_triggers_var : bool -> unit val set_nb_triggers : int -> unit val set_greedy : bool -> unit val set_rm_eq_existential : bool -> unit val set_no_Ematching : bool -> unit val set_nocontracongru : bool -> unit val set_term_like_pp : bool -> unit val set_all_models : bool -> unit val set_model : bool -> unit val set_complete_model : bool -> unit val set_interpretation : int -> unit val set_max_split : Numbers.Q.t -> unit val set_fm_cross_limit : Numbers.Q.t -> unit val set_rewriting : bool -> unit val set_proof : bool -> unit val set_rules : int -> unit val set_restricted : bool -> unit val set_bottom_classes : bool -> unit val set_timelimit : float -> unit val set_thread_yield : (unit -> unit) -> unit (** This functions assumes (asserts) that timers() yields true **) val set_timer_start : (Timers.ty_module -> Timers.ty_function -> unit) -> unit (** This functions assumes (asserts) that timers() yields true **) val set_timer_pause : (Timers.ty_module -> Timers.ty_function -> unit) -> unit val set_timeout : (unit -> unit) -> unit val set_partial_bmodel : bool -> unit val set_save_used_context : bool -> unit (* updates the filename to be parsed and sets a js_mode flag *) val set_file_for_js : string -> unit (** getter functions **********************************************************) (** getters for debug flags *) val debug : unit -> bool val debug_warnings : unit -> bool val debug_cc : unit -> bool val debug_gc : unit -> bool val debug_use : unit -> bool val debug_uf : unit -> bool val debug_fm : unit -> bool val debug_sum : unit -> bool val debug_arith : unit -> bool val debug_bitv : unit -> bool val debug_ac : unit -> bool val debug_sat : unit -> bool val debug_sat_simple : unit -> bool val debug_typing : unit -> bool val debug_constr : unit -> bool val debug_arrays : unit -> bool val debug_types : unit -> bool val debug_combine : unit -> bool val debug_proof : unit -> bool val debug_split : unit -> bool val debug_matching : unit -> int val debug_explanations : unit -> bool (** additional getters *) val enable_assertions : unit -> bool val type_only : unit -> bool val parse_only : unit -> bool val steps_bound : unit -> int val no_tcp : unit -> bool val no_theory : unit -> bool val tighten_vars : unit -> bool val age_bound : unit -> int val notriggers : unit -> bool val triggers_var : unit -> bool val nb_triggers : unit -> int val verbose : unit -> bool val greedy : unit -> bool val rm_eq_existential : unit -> bool val no_Ematching : unit -> bool val no_backjumping : unit -> bool val no_NLA : unit -> bool val no_ac : unit -> bool val nocontracongru : unit -> bool val term_like_pp : unit -> bool val all_models : unit -> bool val model : unit -> bool val interpretation : unit -> int val debug_interpretation : unit -> bool val complete_model : unit -> bool val max_split : unit -> Numbers.Q.t val fm_cross_limit : unit -> Numbers.Q.t val rewriting : unit -> bool val proof : unit -> bool val rules : unit -> int val restricted : unit -> bool val bottom_classes : unit -> bool val timelimit : unit -> float val interpretation_timelimit : unit -> float val profiling : unit -> bool val cumulative_time_profiling : unit -> bool val profiling_period : unit -> float val js_mode : unit -> bool val case_split_policy : unit -> Util.case_split_policy val instantiate_after_backjump : unit -> bool (** this option also yields true if profiling is set to true **) val timers : unit -> bool val replay : unit -> bool val replay_used_context : unit -> bool val replay_all_used_context : unit -> bool val save_used_context : unit -> bool val replay_satml_dfs : unit -> bool val get_file : unit -> string val get_session_file : unit -> string val get_used_context_file : unit -> string val sat_plugin : unit -> string val inequalities_plugin : unit -> string val profiling_plugin : unit -> string val normalize_instances : unit -> bool val partial_bmodel : unit -> bool (** particular getters : functions that are immediately executed **************) val exec_thread_yield : unit -> unit val exec_timer_start : Timers.ty_module -> Timers.ty_function -> unit val exec_timer_pause : Timers.ty_module -> Timers.ty_function -> unit val exec_timeout : unit -> unit val tool_req : int -> string -> unit (** Simple Timer module **) module Time : sig val start : unit -> unit val value : unit -> float val set_timeout : float -> unit val unset_timeout : unit -> unit end (** globals **) val cs_steps : unit -> int val incr_cs_steps : unit -> unit (** open Options in every module to hide polymorphic versions of Pervasives **) val (<>) : int -> int -> bool val (=) : int -> int -> bool val (<) : int -> int -> bool val (>) : int -> int -> bool val (<=) : int -> int -> bool val (>=) : int -> int -> bool val compare : int -> int -> int alt-ergo-1.30/src/util/timers.mli0000644000175000001440000000624213014515065015271 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type ty_module = | M_None | M_Typing | M_Sat | M_Match | M_CC | M_UF | M_Arith | M_Arrays | M_Sum | M_Records | M_AC | M_Formula | M_Literal | M_Term | M_Triggers type ty_function = | F_add | F_add_lemma | F_add_predicate | F_add_terms | F_are_equal | F_assume | F_class_of | F_leaves | F_make | F_m_lemmas | F_m_predicates | F_query | F_solve | F_subst | F_union | F_unsat | F_none | F_new_facts | F_apply_subst | F_instantiate (** environment of internal timers **) type t (** return a new empty env **) val empty : unit -> t (** reset the given env to empty *) val reset : t -> unit (** save the current timer and start the timer "ty_module x ty_function" **) val start : t -> ty_module -> ty_function -> unit (** pause the timer "ty_module x ty_function" and restore the former timer **) val pause : t -> ty_module -> ty_function -> unit (** update the value of the current timer **) val update : t -> unit (** get the value of the timer "ty_module x ty_function" **) val get_value : t -> ty_module -> ty_function -> float (** get the sum of the "ty_function" timers for the given "ty_module" **) val get_sum : t -> ty_module -> float val current_timer : t -> ty_module * ty_function * int val string_of_ty_module : ty_module -> string val string_of_ty_function : ty_function -> string val get_stack : t -> (ty_module * ty_function * int) list val get_timers_array : t -> (float array) array val mtag : ty_module -> int val ftag : ty_function -> int val all_modules : ty_module list val all_functions : ty_function list alt-ergo-1.30/src/util/util.ml0000644000175000001440000000203313014515065014564 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) exception Timeout module MI = Map.Make(struct type t = int let compare a b = a - b end) (** Different values for -case-split-policy option: -after-theory-assume (default value): after assuming facts in theory by the SAT -before-matching: just before performing a matching round -after-matching: just after performing a matching round **) type case_split_policy = | AfterTheoryAssume (* default *) | BeforeMatching | AfterMatching (* let map_merge_is_union eq k a b = match a, b with | None, None -> None | None, Some _ -> b | Some _, None -> a | Some (x, c1), Some (y, c2) -> assert (eq x y); Some (x, c1 + c2) *) alt-ergo-1.30/src/util/myUnix.ml0000644000175000001440000000214313014515065015102 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module Default_Unix = struct open Unix let cur_time () = (times()).tms_utime let set_timeout timelimit = if Pervasives.(<>) timelimit 0. then ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = timelimit; Unix.it_interval = 0. }) let unset_timeout () = ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = 0.; Unix.it_interval = 0. }) end include Default_Unix (* !! This commented code is used when compiling to javascript !! module JavaScript_Unix = struct let cur_time () = let today = jsnew Js.date_now () in let t = Js.to_float (today##getTime()) in t /. 1000. let set_timeout _ = () let unset_timeout () = () end include JavaScript_Unix *) alt-ergo-1.30/src/util/version.ml0000644000175000001440000000134613014515065015302 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (* WARNING: a "cut" is performed on the following file in the Makefile. DO NOT CHANGE its format *) let version="1.30" let release_commit = "(not released)" let release_date = "(not released)" let version="1.30" let release_commit = "0447785ef027702c0cd50a62b86fb28dd54acc08" let release_date = "Mon Nov 21 07:54:45 CET 2016" alt-ergo-1.30/src/util/hashcons.mli0000644000175000001440000001024613014515065015573 0ustar rtusers(**************************************************************************) (* *) (* Copyright (C) 2010- *) (* François Bobot *) (* Jean-Christophe Filliâtre *) (* Claude Marché *) (* Andrei Paskevich *) (* *) (* This software is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License version 2.1, with the special exception on linking *) (* described in file LICENSE. *) (* *) (* This software is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* *) (**************************************************************************) (** Hash tables for hash consing *) (*s Hash tables for hash consing. Hash consed values are of the following type [hash_consed]. The field [tag] contains a unique integer (for values hash consed with the same table). The field [hkey] contains the hash key of the value (without modulo) for possible use in other hash tables (and internally when hash consing tables are resized). The field [node] contains the value itself. Hash consing tables are using weak pointers, so that values that are no more referenced from anywhere else can be erased by the GC. *) module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int val tag : int -> t -> t end module type S = sig type t val hashcons : t -> t (** [hashcons n f] hash-cons the value [n] using function [f] i.e. returns any existing value in the table equal to [n], if any; otherwise, creates a new value with function [f], stores it in the table and returns it. Function [f] is passed the node [n] as first argument and the unique id as second argument. *) val iter : (t -> unit) -> unit (** [iter f] iterates [f] over all elements of the table . *) val stats : unit -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, smallest bucket length, median bucket length, biggest bucket length. *) end module Make(H : HashedType) : (S with type t = H.t) (* helpers *) val combine : int -> int -> int val combine2 : int -> int -> int -> int val combine3 : int -> int -> int -> int -> int val combine_list : ('a -> int) -> int -> 'a list -> int val combine_option : ('a -> int) -> 'a option -> int val combine_pair : ('a -> int) -> ('b -> int) -> 'a * 'b -> int (* For simple use *) type 'a hash_consed = private { tag : int; node : 'a } module type HashedType_consed = sig type t val equal : t -> t -> bool val hash : t -> int end module type S_consed = sig type key val hashcons : key -> key hash_consed (** [hashcons n f] hash-cons the value [n] using function [f] i.e. returns any existing value in the table equal to [n], if any; otherwise, creates a new value with function [f], stores it in the table and returns it. Function [f] is passed the node [n] as first argument and the unique id as second argument. *) val iter : (key hash_consed -> unit) -> unit (** [iter f] iterates [f] over all elements of the table . *) val stats : unit -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, smallest bucket length, median bucket length, biggest bucket length. *) end module Make_consed(H : HashedType_consed) : (S_consed with type key = H.t) alt-ergo-1.30/src/util/myZip.mli0000644000175000001440000000137413014515065015077 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** A wrapper of the Zip module of CamlZip: we use Zip except when we want to generate the.js file for try-Alt-Ergo **) type in_file type entry val open_in : string -> in_file val close_in : in_file -> unit val entries : in_file -> entry list val read_entry : in_file -> entry -> string val filename : entry -> string val is_directory : entry -> bool alt-ergo-1.30/src/util/lists.mli0000644000175000001440000000166413014515065015127 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** [apply f [a_1; ...; a_n]] returns a couple [f a_1; ...; f a_n], same such that: (1) "same" is true if and only if a_i == a_i for each i; and (2) if same is true, then the resulting list is physically equal to the argument **) val apply : ('a -> 'a) -> 'a list -> 'a list * bool (** similar to function apply, but the elements of the list are couples **) val apply_right : ('a -> 'a) -> ('b * 'a) list -> ('b * 'a) list * bool (** An abbreviation of List.rev List.rev_map **) val rrmap : ('a -> 'b) -> 'a list -> 'b list alt-ergo-1.30/src/util/zarithNumbers.mli0000644000175000001440000000346713014515065016631 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (** Integers implementation. Based on Zarith's integers **) module Z : NumbersInterface.ZSig with type t = Z.t (** Rationals implementation. Based on Zarith's rationals **) module Q : NumbersInterface.QSig with module Z = Z alt-ergo-1.30/src/structures/0000755000175000001440000000000013014515065014525 5ustar rtusersalt-ergo-1.30/src/structures/explanation.mli0000644000175000001440000000464613014515065017564 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type t type exp = | Literal of Literal.LT.t | Fresh of int | Bj of Formula.t | Dep of Formula.t val empty : t val is_empty : t -> bool val mem : exp -> t -> bool val singleton : exp -> t val union : t -> t -> t val merge : t -> t -> t val iter_atoms : (exp -> unit) -> t -> unit val fold_atoms : (exp -> 'a -> 'a ) -> t -> 'a -> 'a val fresh_exp : unit -> exp val remove_fresh : exp -> t -> t option val remove : exp -> t -> t val add_fresh : exp -> t -> t val print : Format.formatter -> t -> unit val print_proof : Format.formatter -> t -> unit val formulas_of : t -> Formula.Set.t val bj_formulas_of : t -> Formula.Set.t module MI : Map.S with type key = int val literals_ids_of : t -> int MI.t val make_deps : Formula.Set.t -> t val has_no_bj : t -> bool val compare : t -> t -> int val subset : t -> t -> bool alt-ergo-1.30/src/structures/typed.mli0000644000175000001440000001102513014515065016354 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Parsed type ('a, 'b) annoted = { c : 'a; annot : 'b } type tconstant = | Tint of string | Treal of Num.num | Tbitv of string | Ttrue | Tfalse | Tvoid type 'a tterm = { tt_ty : Ty.t; tt_desc : 'a tt_desc } and 'a tt_desc = | TTconst of tconstant | TTvar of Symbols.t | TTinfix of ('a tterm, 'a) annoted * Symbols.t * ('a tterm, 'a) annoted | TTprefix of Symbols.t * ('a tterm, 'a) annoted | TTapp of Symbols.t * ('a tterm, 'a) annoted list | TTget of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTset of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTextract of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTconcat of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTdot of ('a tterm, 'a) annoted * Hstring.t | TTrecord of (Hstring.t * ('a tterm, 'a) annoted) list | TTlet of Symbols.t * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTnamed of Hstring.t * ('a tterm, 'a) annoted type 'a tatom = | TAtrue | TAfalse | TAeq of ('a tterm, 'a) annoted list | TAdistinct of ('a tterm, 'a) annoted list | TAneq of ('a tterm, 'a) annoted list | TAle of ('a tterm, 'a) annoted list | TAlt of ('a tterm, 'a) annoted list | TApred of ('a tterm, 'a) annoted | TAbuilt of Hstring.t * ('a tterm, 'a) annoted list type 'a oplogic = OPand |OPor | OPimp | OPnot | OPiff | OPif of ('a tterm, 'a) annoted type 'a quant_form = { (* quantified variables that appear in the formula *) qf_bvars : (Symbols.t * Ty.t) list ; qf_upvars : (Symbols.t * Ty.t) list ; qf_triggers : (('a tterm, 'a) annoted list * bool) list; qf_form : ('a tform, 'a) annoted } and 'a tform = | TFatom of ('a tatom, 'a) annoted | TFop of 'a oplogic * (('a tform, 'a) annoted) list | TFforall of 'a quant_form | TFexists of 'a quant_form | TFlet of (Symbols.t * Ty.t) list * Symbols.t * ('a tterm, 'a) annoted * ('a tform, 'a) annoted | TFnamed of Hstring.t * ('a tform, 'a) annoted type 'a rwt_rule = { rwt_vars : (Symbols.t * Ty.t) list; rwt_left : 'a; rwt_right : 'a } type goal_sort = Cut | Check | Thm type 'a tdecl = | TAxiom of Loc.t * string * ('a tform, 'a) annoted | TRewriting of Loc.t * string * (('a tterm, 'a) annoted rwt_rule) list | TGoal of Loc.t * goal_sort * string * ('a tform, 'a) annoted | TLogic of Loc.t * string list * plogic_type | TPredicate_def of Loc.t * string * (string * ppure_type) list * ('a tform, 'a) annoted | TFunction_def of Loc.t * string * (string * ppure_type) list * ppure_type * ('a tform, 'a) annoted | TTypeDecl of Loc.t * string list * string * body_type_decl val print_term : Format.formatter -> ('a tterm, 'a) annoted -> unit val print_formula : Format.formatter -> ('a tform, 'a) annoted -> unit val print_binders : Format.formatter -> (Symbols.t * Ty.t) list -> unit val print_triggers : Format.formatter -> (('a tterm, 'a) annoted list * bool) list -> unit alt-ergo-1.30/src/structures/errors.ml0000644000175000001440000001316213014515065016376 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format type error = | BitvExtract of int*int | BitvExtractRange of int*int | ClashType of string | ClashLabel of string * string | ClashParam of string | TypeDuplicateVar of string | UnboundedVar of string | UnknownType of string | WrongArity of string * int | SymbAlreadyDefined of string | SymbUndefined of string | NotAPropVar of string | NotAPredicate of string | Unification of Ty.t * Ty.t | ShouldBeApply of string | WrongNumberofArgs of string | ShouldHaveType of Ty.t * Ty.t | ShouldHaveTypeIntorReal of Ty.t | ShouldHaveTypeInt of Ty.t | ShouldHaveTypeBitv of Ty.t | ArrayIndexShouldHaveTypeInt | ShouldHaveTypeArray | ShouldHaveTypeRecord of Ty.t | ShouldBeARecord | ShouldHaveLabel of string * string | NoLabelInType of Hstring.t * Ty.t | ShouldHaveTypeProp | NoRecordType of Hstring.t | DuplicateLabel of Hstring.t | WrongLabel of Hstring.t * Ty.t | WrongNumberOfLabels | Notrigger | CannotGeneralize | SyntaxError exception Error of error * Loc.t exception Warning of error * Loc.t let report fmt = function | BitvExtract(i,j) -> fprintf fmt "bitvector extraction malformed (%d>%d)" i j | BitvExtractRange(n,j) -> fprintf fmt "extraction out of range (%d>%d)" j n | ClashType s -> fprintf fmt "the type %s is already defined" s | ClashParam s -> fprintf fmt "parameter %s is bound twice" s | ClashLabel (s,t) -> fprintf fmt "the label %s already appears in type %s" s t | CannotGeneralize -> fprintf fmt "cannot generalize the type of this expression" | TypeDuplicateVar s -> fprintf fmt "duplicate type variable %s" s | UnboundedVar s -> fprintf fmt "unbounded variable %s" s | UnknownType s -> fprintf fmt "unknown type %s" s | WrongArity(s,n) -> fprintf fmt "the type %s has %d arguments" s n | SymbAlreadyDefined s -> fprintf fmt "the symbol %s is already defined" s | SymbUndefined s -> fprintf fmt "undefined symbol %s" s | NotAPropVar s -> fprintf fmt "%s is not a propositional variable" s | NotAPredicate s -> fprintf fmt "%s is not a predicate" s | Unification(t1,t2) -> fprintf fmt "%a and %a cannot be unified" Ty.print t1 Ty.print t2 | ShouldBeApply s -> fprintf fmt "%s is a function symbol, it should be apply" s | WrongNumberofArgs s -> fprintf fmt "Wrong number of arguments when applying %s" s | ShouldHaveType(ty1,ty2) -> fprintf fmt "this expression has type %a but is here used with type %a" Ty.print ty1 Ty.print ty2 | ShouldHaveTypeBitv t -> fprintf fmt "this expression has type %a but it should be a bitvector" Ty.print t | ShouldHaveTypeIntorReal t -> fprintf fmt "this expression has type %a but it should have type int or real" Ty.print t | ShouldHaveTypeInt t -> fprintf fmt "this expression has type %a but it should have type int" Ty.print t | ShouldHaveTypeArray -> fprintf fmt "this expression should have type farray" | ShouldHaveTypeRecord t -> fprintf fmt "this expression has type %a but it should have a record type" Ty.print t | ShouldBeARecord -> fprintf fmt "this expression should have a record type" | ShouldHaveLabel (s, a) -> fprintf fmt "this expression has type %s which has no label %s" s a | NoLabelInType (lb, ty) -> fprintf fmt "no label %s in type %a" (Hstring.view lb) Ty.print ty | ShouldHaveTypeProp -> fprintf fmt "this expression should have type prop" | NoRecordType s -> fprintf fmt "no record type has label %s" (Hstring.view s) | DuplicateLabel s -> fprintf fmt "label %s is defined several times" (Hstring.view s) | WrongLabel (s, ty) -> fprintf fmt "wrong label %s in type %a" (Hstring.view s) Ty.print ty | WrongNumberOfLabels -> fprintf fmt "wrong number of labels" | ArrayIndexShouldHaveTypeInt -> fprintf fmt "index of arrays should hava type int" | Notrigger -> fprintf fmt "No trigger for this lemma" | SyntaxError -> fprintf fmt "syntax error" let error e l = raise (Error(e,l)) let warning e l = raise (Warning(e,l)) alt-ergo-1.30/src/structures/term.mli0000644000175000001440000000631413014515065016203 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type t type view = private {f: Symbols.t ; xs: t list; ty: Ty.t; depth: int; tag: int; vars : Ty.t Symbols.Map.t Lazy.t; vty : Ty.Svty.t Lazy.t} module Subst : sig include Map.S with type key = Symbols.t and type 'a t = 'a Symbols.Map.t val print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit end type subst = t Subst.t * Ty.subst module Map : Map.S with type key = t module Set : Set.S with type elt = t val view : t -> view val make : Symbols.t -> t list -> Ty.t -> t val shorten : t -> t val vrai : t val faux : t val void : t val int : string -> t val real : string -> t val bitv : string -> Ty.t -> t val fresh_name : Ty.t -> t val is_fresh : t -> bool val is_fresh_skolem : t -> bool val is_int : t -> bool val is_real : t -> bool val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val vars_of : t -> Ty.t Symbols.Map.t -> Ty.t Symbols.Map.t val vty_of : t -> Ty.Svty.t val pred : t -> t val apply_subst : subst -> t -> t val compare_subst : subst -> subst -> int val equal_subst : subst -> subst -> bool val fold_subst_term : (Symbols.t -> t -> 'b -> 'b) -> subst -> 'b -> 'b val union_subst : subst -> subst -> subst val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val is_in_model : t -> bool val print : Format.formatter -> t -> unit val print_list : Format.formatter -> t list -> unit val print_list_sep : string -> Format.formatter -> t list -> unit val print_tagged_classes : Format.formatter -> Set.t list -> unit val subterms : Set.t -> t -> Set.t val type_info : t -> Ty.t val top : unit -> t val bot : unit -> t val is_ground : t -> bool alt-ergo-1.30/src/structures/formula.mli0000644000175000001440000001100213014515065016667 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type t type binders = (Ty.t * int) Symbols.Map.t (*int tag in globally unique *) type trigger = { content : Term.t list; depth : int; from_user : bool; guard : Literal.LT.t option } type quantified = { name : string; main : t; (*simplified quantified formula, or immediate inst*) simple_inst : (Term.t Symbols.Map.t * Ty.subst) option; triggers : trigger list; binders : binders; (* quantified variable *) (* These fields should be (ordered) lists ! important for skolemization *) free_v : Term.t list; (* free variables in main *) free_vty : Ty.t list; (* free type variables in main *) loc : Loc.t; (* location of the "GLOBAL" axiom containing this quantified formula. It forms with name a unique id *) } and llet = { let_var: Symbols.t; let_subst : Term.subst; let_term : Term.t; let_f : t; } and view = Unit of t*t (* unit clauses *) | Clause of t*t*bool (* a clause (t1 or t2) bool <-> is implication *) | Literal of Literal.LT.t (* an atom *) | Lemma of quantified (* a lemma *) | Skolem of quantified (* lazy skolemization *) | Let of llet (* a binding of a term *) type gformula = { f: t; nb_reductions : int; trigger_depth : int; age: int; lem: t option; from_terms : Term.t list; mf: bool; gf: bool; } val mk_binders : Term.Set.t -> binders val mk_not : t -> t val mk_and : t -> t -> bool -> int -> t (* bool <-> is implication (neg) *) val mk_or : t -> t -> bool -> int -> t (* bool <-> is implication *) val mk_imp : t -> t -> int -> t val mk_if : Term.t -> t -> t -> int -> t val mk_iff : t -> t -> int -> t val mk_lit : Literal.LT.t -> int -> t val mk_forall : string -> (* name *) Loc.t -> (* location in the original file *) binders -> (* quantified variables *) trigger list -> (* triggers *) t -> (* quantified formula *) int -> (* id, for the GUI *) (Term.t list * Ty.t list) option -> (* free_vars and free_vty: they are computed if None is given *) t val mk_exists : string -> (* name *) Loc.t -> (* location in the original file *) binders -> (* quantified variables *) trigger list -> (* triggers *) t -> (* quantified formula *) int -> (* id, for the GUI *) (Term.t list * Ty.t list) option -> (* free_vars and free_vty: they are computed if None is given *) t val mk_let : Term.Set.t -> Symbols.t -> Term.t -> t -> int -> t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val is_in_model : t -> bool val view : t -> view val size : t -> int val id : t -> int val print : Format.formatter -> t -> unit val ground_terms_rec : t -> Term.Set.t val free_vars : t -> Ty.t Symbols.Map.t val apply_subst : Term.subst -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val vrai : t val faux : t val skolemize : quantified -> t val type_variables: t -> Ty.Set.t val max_term_depth : t -> int module Set : Set.S with type elt = t module Map : Map.S with type key = t alt-ergo-1.30/src/structures/exception.mli0000644000175000001440000000343013014515065017226 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) exception Unsolvable exception Inconsistent of Explanation.t * Term.Set.t list exception Progress exception NotCongruent exception Trivial exception Interpreted_Symbol exception Compared of int alt-ergo-1.30/src/structures/literal.mli0000644000175000001440000000656413014515065016677 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type 'a view = private | Eq of 'a * 'a | Distinct of bool * 'a list | Builtin of bool * Hstring.t * 'a list | Pred of 'a * bool type 'a atom_view (* We do not need to export internal representation of literals ! = | EQ of 'a * 'a | BT of Hstring.t * 'a list | PR of 'a | EQ_LIST of 'a list*) module type OrderedType = sig type t val compare : t -> t -> int val hash : t -> int val print : Format.formatter -> t -> unit val top : unit -> t val bot : unit -> t val type_info : t -> Ty.t end module type S = sig type elt type t val make : elt view -> t val view : t -> elt view val atom_view : t -> elt atom_view * bool (* is_negated ? *) val mk_eq : elt -> elt -> t val mk_distinct : bool -> elt list -> t val mk_builtin : bool -> Hstring.t -> elt list -> t val mk_pred : elt -> bool -> t val mkv_eq : elt -> elt -> elt view val mkv_distinct : bool -> elt list -> elt view val mkv_builtin : bool -> Hstring.t -> elt list -> elt view val mkv_pred : elt -> bool -> elt view val neg : t -> t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val print : Format.formatter -> t -> unit val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val uid : t -> int module Map : Map.S with type key = t module Set : Set.S with type elt = t end module Make ( X : OrderedType ) : S with type elt = X.t module type S_Term = sig include S with type elt = Term.t val vrai : t val faux : t val apply_subst : Term.subst -> t -> t val terms_nonrec : t -> Term.Set.t val terms_rec : t -> Term.Set.t val vars_of : t -> Ty.t Symbols.Map.t -> Ty.t Symbols.Map.t val is_ground : t -> bool val is_in_model : t -> bool end module LT : S_Term alt-ergo-1.30/src/structures/parsed.ml0000644000175000001440000000750213014515065016341 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options type constant = | ConstBitv of string | ConstInt of string | ConstReal of Num.num | ConstTrue | ConstFalse | ConstVoid type pp_infix = | PPand | PPor | PPimplies | PPiff | PPlt | PPle | PPgt | PPge | PPeq | PPneq | PPadd | PPsub | PPmul | PPdiv | PPmod type pp_prefix = | PPneg | PPnot type ppure_type = | PPTint | PPTbool | PPTreal | PPTunit | PPTbitv of int | PPTvarid of string * Loc.t | PPTexternal of ppure_type list * string * Loc.t type lexpr = { pp_loc : Loc.t; pp_desc : pp_desc } and pp_desc = | PPvar of string | PPapp of string * lexpr list | PPdistinct of lexpr list | PPconst of constant | PPinfix of lexpr * pp_infix * lexpr | PPprefix of pp_prefix * lexpr | PPget of lexpr * lexpr | PPset of lexpr * lexpr * lexpr | PPdot of lexpr * string | PPrecord of (string * lexpr) list | PPwith of lexpr * (string * lexpr) list | PPextract of lexpr * lexpr * lexpr | PPconcat of lexpr * lexpr | PPif of lexpr * lexpr * lexpr | PPforall of string list * ppure_type * (lexpr list * bool) list * lexpr | PPexists of string list * ppure_type * (lexpr list * bool) list * lexpr | PPforall_named of (string * string) list * ppure_type * (lexpr list * bool) list * lexpr | PPexists_named of (string * string) list * ppure_type * (lexpr list * bool) list * lexpr | PPnamed of string * lexpr | PPlet of string * lexpr * lexpr | PPcheck of lexpr | PPcut of lexpr | PPcast of lexpr * ppure_type (* Declarations. *) type plogic_type = | PPredicate of ppure_type list | PFunction of ppure_type list * ppure_type type name_kind = Symbols.name_kind type body_type_decl = | Record of (string * ppure_type) list (* lbl : t *) | Enum of string list | Abstract type decl = | Axiom of Loc.t * string * lexpr | Rewriting of Loc.t * string * lexpr list | Goal of Loc.t * string * lexpr | Logic of Loc.t * name_kind * (string * string) list * plogic_type | Predicate_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * lexpr | Function_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * ppure_type * lexpr | TypeDecl of Loc.t * string list * string * body_type_decl type file = decl list alt-ergo-1.30/src/structures/formula.ml0000644000175000001440000005537213014515065016540 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Hashcons open Options module T = Term module Sy = Symbols type binders = (Ty.t * int) Sy.Map.t (*int tag in globally unique *) type trigger = { content : T.t list; depth : int; from_user : bool; guard : Literal.LT.t option } type quantified = { name : string; main : t; (*simplified quantified formula, or immediate inst*) simple_inst : (Term.t Symbols.Map.t * Ty.subst) option; triggers : trigger list; binders : binders; (* These fields should be (ordered) lists ! important for skolemization *) free_v : T.t list; free_vty : Ty.t list; loc : Loc.t; (* location of the "GLOBAL" axiom containing this quantified formula. It forms with name a unique id *) } and llet = { let_var: Symbols.t; let_subst : Term.subst; let_term : Term.t; let_f : t; } and view = Unit of t*t | Clause of t*t*bool | Literal of Literal.LT.t | Lemma of quantified | Skolem of quantified | Let of llet and iview = { pos : view ; neg : view ; size : int; tag : int ; negation : iview} and t = iview * int type gformula = { f: t; nb_reductions : int; trigger_depth : int; age: int; lem: t option; from_terms : Term.t list; mf: bool; gf: bool; } let size (t,_) = t.size let compare ((v1,_) as f1) ((v2,_) as f2) = let c = Pervasives.compare (size f1) (size f2) in if c=0 then Pervasives.compare v1.tag v2.tag else c let equal (f1,_) (f2,_) = assert ((f1 == f2) == (f1.tag == f2.tag)); f1 == f2 let equal_binders b1 b2 = Sy.Map.equal (fun (_,i) (_,j) -> i = j) b1 b2 let equal_free_vars = let set_of l = List.fold_left (fun z t -> T.Set.add t z) T.Set.empty l in fun l1 l2 -> let st2 = set_of l2 in List.for_all (fun ty -> T.Set.mem ty st2) l1 let equal_free_vty = let set_of l = List.fold_left (fun z t -> Ty.Set.add t z) Ty.Set.empty l in fun l1 l2 -> let st2 = set_of l2 in List.for_all (fun ty -> Ty.Set.mem ty st2) l1 module MST = Map.Make(T.Set) let equal_triggers = let map_of l = List.fold_left (fun mp {content=mtr; guard = opt} -> let st = List.fold_left (fun z t -> T.Set.add t z) T.Set.empty mtr in MST.add st opt mp )MST.empty l in let equal_opt o1 o2 = match o1, o2 with | None, None -> true | Some a, Some b -> Literal.LT.equal a b | _ -> false in fun trs1 trs2 -> MST.equal equal_opt (map_of trs1) (map_of trs2) let equal_quant {main=f1; binders=b1; free_v=free_v1; free_vty=free_vty1; triggers=trs1} {main=f2; binders=b2; free_v=free_v2; free_vty=free_vty2; triggers=trs2} = equal f1 f2 && equal_binders b1 b2 && equal_free_vars free_v1 free_v2 && equal_free_vty free_vty1 free_vty2 && equal_triggers trs1 trs2 let hash (f, _) = f.tag let view (t,_) = t.pos let hash_quant acc q = let { name = name; main = main; triggers = triggers; binders = binders; free_v = free_v; free_vty = free_vty; } = q in let acc = (fst main).tag + 13*acc in let acc = Sy.Map.fold (fun sy (ty, i) acc -> i * (Ty.hash ty) + 13*acc) binders acc in let acc = List.fold_left (fun acc t -> (T.hash t) + 13*acc) acc free_v in let acc = List.fold_left (fun acc ty -> (Ty.hash ty) + 13*acc) acc free_vty in acc let rec is_positive v = match v with | Unit _ | Lemma _ -> true | Clause _ | Skolem _ -> false | Literal a -> snd (Literal.LT.atom_view a) | Let llet -> is_positive (view llet.let_f) module View = struct type t = iview let eqc c1 c2 = match c1,c2 with | Literal x , Literal y -> Literal.LT.equal x y | Unit(f1,f2), Unit(g1,g2) | Clause(f1,f2,_), Clause(g1,g2,_) -> equal f1 g1 && equal f2 g2 || equal f1 g2 && equal f2 g1 | Lemma q1, Lemma q2 | Skolem q1, Skolem q2 -> equal_quant q1 q2 | Let l1, Let l2 -> fst l1.let_f == fst l2.let_f && Sy.equal l1.let_var l2.let_var && Term.equal l1.let_term l2.let_term && Term.compare_subst l1.let_subst l2.let_subst = 0 | _, _ -> false let hashlt = List.fold_left (fun acc x->acc*19 + T.hash x) let hashllt = List.fold_left (fun acc (x, _) ->acc*19 + hashlt 0 x) let hashc acc = function | Literal x -> Literal.LT.hash x | Unit((f1,_),(f2,_)) -> (* XXX : Same as Clause ? *) let min = min f1.tag f2.tag in let max = max f1.tag f2.tag in (acc*19 + min)*19 + max | Clause((f1,_),(f2,_),_) -> let min = min f1.tag f2.tag in let max = max f1.tag f2.tag in (acc*19 + min)*19 + max | Lemma q -> 2*hash_quant acc q | Skolem q -> 1 + 2*hash_quant acc q | Let ({let_var=lvar; let_term=lterm; let_subst=s; let_f=(lf,_)}) -> T.fold_subst_term (fun s t acc ->acc * 19 + Sy.hash s) s (lf.tag * 19 * 19 + Sy.hash lvar * 19 + acc) let equal f1 f2 = eqc f1.pos f2.pos && eqc f1.neg f2.neg let hash f = abs (hashc (hashc 1 f.pos) f.neg) let tag tag {pos=pos; neg=neg; size=size} = (*assert (is_positive (pos));*) let rec p = {pos = pos; neg = neg; size = size; tag = 2*tag; negation = n} and n = {pos = neg; neg = pos; size = size; tag = 2*tag+1; negation = p} in p end module H = Make(View) let iview f = f let id (_,id) = id let print_binders = let print_one fmt (sy, (ty, _)) = fprintf fmt "%a:%a" Sy.print sy Ty.print ty in fun fmt b -> match Sy.Map.bindings b with | [] -> (* can happen when quantifying only on type variables *) fprintf fmt "(no term variables)" | e::l -> print_one fmt e; List.iter (fun e -> fprintf fmt ", %a" print_one e) l let rec print fmt f = match view f with | Literal a -> Literal.LT.print fmt a | Lemma {triggers = trs; main = f; name = n; binders} -> if verbose () then let first = ref true in fprintf fmt "(lemma: %s forall %a.)[%a]@ %a" n print_binders binders (fun fmt -> List.iter (fun {content=l} -> fprintf fmt "%s%a" (if !first then "" else " | ") T.print_list l; first := false; )) trs print f else fprintf fmt "lem %s" n | Unit(f1, f2) -> fprintf fmt "@[(%a /\\@ %a)@]" print f1 print f2 | Clause(f1, f2,_) -> fprintf fmt "@[(%a \\/@ %a)@]" print f1 print f2 | Skolem{main=f; binders} -> fprintf fmt " (%a)" print_binders binders print f | Let l -> fprintf fmt "let %a =@ %a in@ %a" Sy.print l.let_var Term.print l.let_term print l.let_f (* let print fmt ((_,id) as f) = *) (* fprintf fmt "(%d)%a" id print f *) let union_subst s1 ((s2,s2_ty) as subst) = Sy.Map.fold (fun k x s2 -> Sy.Map.add k x s2) (Sy.Map.map (T.apply_subst subst) s1) s2 let mk_not (f,id) = f.negation, id (* smart constructors *) let make pos neg size id = let rec p = {pos = pos; neg = neg; size = size; tag = -1; negation = n} and n = {pos = neg; neg = pos; size = size; tag = -1; negation = p} in if is_positive pos then H.hashcons p, id else mk_not (H.hashcons n, id) let vrai = make (Literal Literal.LT.vrai) (Literal Literal.LT.faux) 1 0 let faux = mk_not vrai let mk_binders = let cpt = ref 0 in fun st -> T.Set.fold (fun t sym -> incr cpt; match T.view t with | {T.f=(Sy.Var _) as v; ty=ty} -> Sy.Map.add v (ty, !cpt) sym | _ -> assert false )st Sy.Map.empty module F_Htbl = Hashtbl.Make(struct type t'=t type t=t' let hash = hash let equal = equal end) let merge_maps acc b = Sy.Map.merge (fun sy a b -> match a, b with | None, None -> assert false | Some _, None -> a | _ -> b ) acc b let free_vars = let rec free_rec acc f = match view f with | Literal a -> Literal.LT.vars_of a acc | Unit(f1,f2) -> free_rec (free_rec acc f1) f2 | Clause(f1,f2,_) -> free_rec (free_rec acc f1) f2 | Lemma {binders = binders; main = f} | Skolem {binders = binders; main = f} -> let mp = free_rec Sy.Map.empty f in let mp = Sy.Map.filter (fun sy _ -> not (Sy.Map.mem sy binders)) mp in merge_maps mp acc | Let {let_subst = (subst, _); let_term = t; let_f = lf} -> let mp = free_rec Sy.Map.empty lf in let mp = Term.vars_of t mp in let mp = Sy.Map.fold (fun sy t mp -> if Sy.Map.mem sy mp then (* 'let' bindings are removed since they are mapped to fresh terms 'vars' that are not nrmalized are replaced with the vars of their normal form w.r.t. subst *) Term.vars_of t (Sy.Map.remove sy mp) else mp ) subst mp in merge_maps mp acc in fun f -> free_rec Sy.Map.empty f let type_variables f = let rec aux acc f = match view f with | Unit(f1,f2) | Clause(f1,f2,_) -> aux (aux acc f1) f2 | Lemma lem | Skolem lem -> aux acc lem.main | Let llet -> aux acc llet.let_f | Literal a -> Term.Set.fold (fun t z -> Ty.Svty.union z (T.vty_of t)) (Literal.LT.terms_nonrec a) acc in Ty.Svty.fold (fun i z -> Ty.Set.add (Ty.Tvar {Ty.v=i; value = None}) z) (aux Ty.Svty.empty f) Ty.Set.empty exception Particuar_instance of Sy.t * Term.t let eventual_particular_inst = let rec aux v tv f = match view f with | Unit _ | Lemma _ | Skolem _ | Let _ -> () | Clause(f1, f2,_) -> aux v tv f1; aux v tv f2 | Literal a -> begin match Literal.LT.view a with | Literal.Distinct (false, [a;b]) when Term.equal tv a -> if not (Sy.Map.mem v (T.vars_of b Sy.Map.empty)) then raise (Particuar_instance (v, b)) | Literal.Distinct (false, [a;b]) when Term.equal tv b -> if not (Sy.Map.mem v (T.vars_of a Sy.Map.empty)) then raise (Particuar_instance (v, a)) | Literal.Pred (t, is_neg) when Term.equal tv t -> raise (Particuar_instance (v, if is_neg then T.vrai else T.faux)) | _ -> () end in fun binders free_vty f -> match free_vty with | _::_ -> None | [] -> match Sy.Map.bindings binders with | [] -> assert false | _::_::_ -> None | [v, (ty,_)] -> try aux v (Term.make v [] ty) f; None with Particuar_instance (x, t) -> Some (Sy.Map.singleton x t, Ty.esubst) let mk_forall = let env = F_Htbl.create 101 in (*fun up bv trs f name id ->*) fun name loc binders triggers f id ext_free -> let free_vty = type_variables f in (* type variables of f*) let free_v_f = free_vars f in (* free variables of f *) let binders = (* ignore binders that are not used in f *) Sy.Map.filter (fun sy _ -> Sy.Map.mem sy free_v_f) binders in if Sy.Map.is_empty binders && Ty.Set.is_empty free_vty then (* not quantified ==> should fix save-used-context to be able to save "non-quantified axioms", or use a cache to save the name of axioms as labels, but they should be unique in this case *) f else let free_v, free_vty = match ext_free with | Some (fv, fv_ty) -> fv, fv_ty | None -> let free_v = (* compute free vars (as terms) of f *) Sy.Map.fold (fun sy ty fv -> if Sy.Map.mem sy binders then fv else (Term.make sy [] ty) ::fv) free_v_f [] in free_v, Ty.Set.elements free_vty in let simple_inst = eventual_particular_inst binders free_vty f in let new_q = { name = name; simple_inst = simple_inst; main = f; triggers = triggers; binders = binders; free_v = free_v; free_vty = free_vty; loc = loc } in try let lem = F_Htbl.find env f in let q = match view lem with Lemma q -> q | _ -> assert false in assert (equal q.main f (* should be true *)); if not (equal_quant q new_q) then raise Exit; if debug_warnings () then eprintf "[warning] (sub) axiom %s replaced with %s@." name q.name; lem with Not_found | Exit -> let sko = {new_q with main = mk_not f} in let res = make (Lemma new_q) (Skolem sko) (size f) id in F_Htbl.add env f res; res let mk_exists name loc binders triggers f id ext_free = mk_not (mk_forall name loc binders triggers (mk_not f) id ext_free) (* forall up. let bv = t in f *) let mk_let _up bv t f id = let {Term.ty=ty} = Term.view t in let up = Term.vars_of t Sy.Map.empty in let up = Sy.Map.fold (fun sy ty acc -> (Term.make sy [] ty)::acc) up [] in let subst = Sy.Map.add bv (T.make (Sy.fresh "_let") up ty) Sy.Map.empty in make (Let{let_var=bv; let_subst=(subst, Ty.esubst); let_term=t; let_f=f}) (Let{let_var=bv; let_subst=(subst, Ty.esubst); let_term=t; let_f=mk_not f}) (size f) id let mk_and f1 f2 is_impl id = if equal f1 (mk_not f2) then faux else if equal f1 f2 then f1 else if equal f1 vrai then f2 else if equal f2 vrai then f1 else if (equal f1 faux) || (equal f2 faux) then faux else let f1, f2 = if is_impl || compare f1 f2 < 0 then f1, f2 else f2, f1 in let size = size f1 + size f2 in make (Unit(f1,f2)) (Clause(mk_not f1,mk_not f2,is_impl)) size id let mk_or f1 f2 is_impl id = if equal f1 (mk_not f2) then vrai else if equal f1 f2 then f1 else if equal f1 faux then f2 else if equal f2 faux then f1 else if equal f1 vrai || equal f2 vrai then vrai else let f1, f2 = if is_impl || compare f1 f2 < 0 then f1, f2 else f2, f1 in let size = size f1 + size f2 in make (Clause(f1,f2,is_impl)) (Unit(mk_not f1,mk_not f2)) size id let mk_imp f1 f2 id = mk_or (mk_not f1) f2 true id (* using simplifications of mk_or and mk_and is not always efficient !! *) let mk_iff f1 f2 id = (* try to interpret iff as a double implication *) let a = mk_or (mk_not f1) f2 true id in let b = mk_or f1 (mk_not f2) true id in mk_and a b false id let translate_eq_to_iff s t = (T.view s).T.ty == Ty.Tbool && not (T.equal s T.vrai || T.equal s T.faux || T.equal t T.vrai ||T.equal t T.faux) let mk_lit a id = match Literal.LT.view a with | Literal.Eq(s,t) when translate_eq_to_iff s t -> let a1 = Literal.LT.mk_pred s false in let a2 = Literal.LT.mk_pred t false in let f1 = make (Literal a1) (Literal (Literal.LT.neg a1)) 1 id in let f2 = make (Literal a2) (Literal (Literal.LT.neg a2)) 1 id in mk_iff f1 f2 id | Literal.Distinct(false,[s;t]) when translate_eq_to_iff s t -> let a1 = Literal.LT.mk_pred s false in let a2 = Literal.LT.mk_pred t false in let f1 = make (Literal a1) (Literal (Literal.LT.neg a1)) 1 id in let f2 = make (Literal a2) (Literal (Literal.LT.neg a2)) 1 id in mk_not (mk_iff f1 f2 id) | _ -> make (Literal a) (Literal (Literal.LT.neg a)) 1 id let mk_if t f2 f3 id = let lit = mk_lit (Literal.LT.mk_pred t false) id in mk_or (mk_and lit f2 true id) (mk_and (mk_not lit) f3 true id) false id let no_capture_issue s_t binders = true (* TODO *) module Set = Set.Make(struct type t'=t type t=t' let compare=compare end) module Map = Map.Make(struct type t'=t type t=t' let compare=compare end) let apply_subst_trigger subst ({content; guard} as tr) = {tr with content = List.map (T.apply_subst subst) content; guard = match guard with | None -> guard | Some g -> Some (Literal.LT.apply_subst subst g) } (* this function should only be applied with ground substitutions *) let rec apply_subst = fun subst ((f, id) as ff) -> let {pos=p;neg=n;size=s} = iview f in let sp, sn, same = iapply_subst subst p n in if same then ff else match sp with | Literal a -> mk_lit a id (* this may simplifies the res *) | Unit (f1, f2) -> let is_impl = match sn with Clause(_,_,b) -> b | _ -> assert false in mk_and f1 f2 is_impl id (* this may simplifies the res *) | Clause (f1,f2,is_impl) -> mk_or f1 f2 is_impl id (* this may simplifies the res *) | Lemma q -> mk_forall q.name q.loc q.binders q.triggers q.main id (Some (q.free_v, q.free_vty)) | Skolem q -> mk_exists q.name q.loc q.binders q.triggers q.main id (Some (q.free_v, q.free_vty)) | _ -> make sp sn s id and iapply_subst ((s_t,s_ty) as subst) p n = match p, n with | Literal a, Literal _ -> let sa = Literal.LT.apply_subst subst a in let nsa = Literal.LT.neg sa in if a == sa then p, n, true else Literal sa, Literal nsa , false | Lemma lem, Skolem sko | Skolem sko, Lemma lem -> let { main = f; triggers = trs; binders = binders; free_v = fr_v; free_vty = fr_vty } = lem in assert (no_capture_issue s_t binders); let s_t = Sy.Map.fold (fun sy _ s_t -> Sy.Map.remove sy s_t) binders s_t in let s_t = (* discard the variables of s_t that are not in free_v *) List.fold_left (fun s_t' tv -> match T.view tv with | {T.f=(Sy.Var _) as x; xs = []} when Sy.Map.mem x s_t -> Sy.Map.add x (Sy.Map.find x s_t) s_t' | _ -> s_t' )Sy.Map.empty fr_v in (* should do the same filtering for fr_vty *) if (Sy.Map.is_empty s_t) && (Ty.M.is_empty s_ty) then p, n, true (* (s_t, s_ty) does not apply *) else let subst = s_t , s_ty in let f = apply_subst subst f in let trs = List.map (apply_subst_trigger subst) trs in let binders = Sy.Map.fold (fun sy (ty,i) bders -> let ty' = Ty.apply_subst s_ty ty in if Ty.compare ty ty' = 0 then bders else Sy.Map.add sy (ty', i) bders )binders binders in let fr_v = List.rev (List.rev_map (T.apply_subst subst) fr_v) in let fr_vty = List.rev (List.rev_map (Ty.apply_subst s_ty) fr_vty) in let lem = {lem with main = f; triggers = trs; binders = binders; free_v = fr_v; free_vty = fr_vty } in let slem = Lemma lem in let ssko = Skolem {lem with main = mk_not f} in (match p, n with | Lemma _, Skolem _ -> slem, ssko, false (* a lot of cmp needed to hcons*) | Skolem _, Lemma _ -> ssko, slem, false | _ -> assert false) | Unit(f1, f2), Clause(_,_, is_impl) -> let sf1 = apply_subst subst f1 in let sf2 = apply_subst subst f2 in if sf1 == f1 && sf2 == f2 then p, n, true else Unit(sf1, sf2), Clause(mk_not sf1, mk_not sf2, is_impl), false | Clause(f1, f2, is_impl), _ -> let sf1 = apply_subst subst f1 in let sf2 = apply_subst subst f2 in if sf1 == f1 && sf2 == f2 then p, n, true else Clause(sf1, sf2, is_impl), Unit(mk_not sf1, mk_not sf2), false | Let ({let_subst = s; let_term = lterm; let_f = lf} as e), Let _ -> let lterm = T.apply_subst subst lterm in let se = { e with let_subst = T.union_subst s subst; let_term = lterm } in let sne = { se with let_f = mk_not lf } in Let se, Let sne, false | _ -> assert false let add_label lbl f = match view f with | Literal a -> Literal.LT.add_label lbl a; Literal.LT.add_label lbl (Literal.LT.neg a) | _ -> () let label f = match view f with | Literal l -> Literal.LT.label l | _ -> Hstring.empty let label_model h = try Pervasives.(=) (String.sub (Hstring.view h) 0 6) "model:" with Invalid_argument _ -> false let is_in_model f = match view f with | Literal l -> label_model (Literal.LT.label l) || Literal.LT.is_in_model l | _ -> false let ground_terms_rec = let rec terms acc f = match view f with | Literal a -> let s = T.Set.filter (fun t-> Sy.Map.is_empty (T.vars_of t Sy.Map.empty) && Ty.Svty.is_empty (T.vty_of t) ) (Literal.LT.terms_rec a) in T.Set.union s acc | Lemma {main = f} | Skolem {main = f} -> terms acc f | Unit(f1,f2) -> terms (terms acc f1) f2 | Clause(f1,f2,_) -> terms (terms acc f1) f2 | Let {let_term=t; let_f=lf} -> let st = T.Set.filter (fun t-> Sy.Map.is_empty (T.vars_of t Sy.Map.empty) && Ty.Svty.is_empty (T.vty_of t)) (Term.subterms Term.Set.empty t) in terms (T.Set.union st acc) lf in terms T.Set.empty let skolemize {main=f; binders=binders; free_v=free_v; free_vty=free_vty} = let tyvars = ignore (flush_str_formatter ()); List.iter (fun ty -> assert (Ty.Svty.is_empty (Ty.vty_of ty)); fprintf str_formatter "<%a>" Ty.print ty ) free_vty; flush_str_formatter () in let mk_sym cpt s = (* garder le suffixe "__" car cela influence l'ordre *) Sy.name (Format.sprintf "!?__%s%s!%d" s tyvars cpt) in let sbt = Symbols.Map.fold (fun x (ty,i) m -> Sy.Map.add x (T.make (mk_sym i "_sko") free_v ty) m) binders Sy.Map.empty in apply_subst (sbt, Ty.esubst) f let apply_subst s f = if Options.timers() then try Options.exec_timer_start Timers.M_Formula Timers.F_apply_subst; let res = apply_subst s f in Options.exec_timer_pause Timers.M_Formula Timers.F_apply_subst; res with e -> Options.exec_timer_pause Timers.M_Formula Timers.F_apply_subst; raise e else apply_subst s f let max_term_depth f = let rec aux f mx = match view f with | Literal a -> T.Set.fold (fun t mx -> max mx (T.view t).T.depth) (Literal.LT.terms_nonrec a) mx | Clause(f1, f2,_) | Unit(f1, f2) -> aux f2 (aux f1 mx) | Lemma q | Skolem q -> aux q.main mx | Let q -> max (aux q.let_f mx) (T.view q.let_term).T.depth in aux f 0 alt-ergo-1.30/src/structures/symbols.mli0000644000175000001440000000512513014515065016723 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type operator = | Plus | Minus | Mult | Div | Modulo | Concat | Extract | Get | Set | Access of Hstring.t | Record type name_kind = Ac | Constructor | Other type t = | True | False | Void | Name of Hstring.t * name_kind | Int of Hstring.t | Real of Hstring.t | Bitv of string | Op of operator | Var of Hstring.t val name : ?kind:name_kind -> string -> t val var : string -> t val underscoring : t -> t val int : string -> t val real : string -> t val is_ac : t -> bool val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val to_string : t -> string val print : Format.formatter -> t -> unit val to_string_clean : t -> string val print_clean : Format.formatter -> t -> unit val dummy : t val fresh : string -> t val is_get : t -> bool val is_set : t -> bool val fake_eq : t val fake_neq : t val fake_lt : t val fake_le : t module Map : Map.S with type key = t module Set : Set.S with type elt = t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t alt-ergo-1.30/src/structures/exception.ml0000644000175000001440000000343013014515065017055 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) exception Unsolvable exception Inconsistent of Explanation.t * Term.Set.t list exception Progress exception NotCongruent exception Trivial exception Interpreted_Symbol exception Compared of int alt-ergo-1.30/src/structures/errors.mli0000644000175000001440000000535313014515065016552 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type error = | BitvExtract of int*int | BitvExtractRange of int*int | ClashType of string | ClashLabel of string * string | ClashParam of string | TypeDuplicateVar of string | UnboundedVar of string | UnknownType of string | WrongArity of string * int | SymbAlreadyDefined of string | SymbUndefined of string | NotAPropVar of string | NotAPredicate of string | Unification of Ty.t * Ty.t | ShouldBeApply of string | WrongNumberofArgs of string | ShouldHaveType of Ty.t * Ty.t | ShouldHaveTypeIntorReal of Ty.t | ShouldHaveTypeInt of Ty.t | ShouldHaveTypeBitv of Ty.t | ArrayIndexShouldHaveTypeInt | ShouldHaveTypeArray | ShouldHaveTypeRecord of Ty.t | ShouldBeARecord | ShouldHaveLabel of string * string | NoLabelInType of Hstring.t * Ty.t | ShouldHaveTypeProp | NoRecordType of Hstring.t | DuplicateLabel of Hstring.t | WrongLabel of Hstring.t * Ty.t | WrongNumberOfLabels | Notrigger | CannotGeneralize | SyntaxError exception Error of error * Loc.t exception Warning of error * Loc.t val report : Format.formatter -> error -> unit val error : error -> Loc.t -> 'a val warning : error -> Loc.t -> 'a alt-ergo-1.30/src/structures/typed.ml0000644000175000001440000001640413014515065016211 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Parsed open Options type ('a, 'b) annoted = { c : 'a; annot : 'b } type tconstant = | Tint of string | Treal of Num.num | Tbitv of string | Ttrue | Tfalse | Tvoid type 'a tterm = { tt_ty : Ty.t; tt_desc : 'a tt_desc } and 'a tt_desc = | TTconst of tconstant | TTvar of Symbols.t | TTinfix of ('a tterm, 'a) annoted * Symbols.t * ('a tterm, 'a) annoted | TTprefix of Symbols.t * ('a tterm, 'a) annoted | TTapp of Symbols.t * ('a tterm, 'a) annoted list | TTget of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTset of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTextract of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTconcat of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTdot of ('a tterm, 'a) annoted * Hstring.t | TTrecord of (Hstring.t * ('a tterm, 'a) annoted) list | TTlet of Symbols.t * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTnamed of Hstring.t * ('a tterm, 'a) annoted type 'a tatom = | TAtrue | TAfalse | TAeq of ('a tterm, 'a) annoted list | TAdistinct of ('a tterm, 'a) annoted list | TAneq of ('a tterm, 'a) annoted list | TAle of ('a tterm, 'a) annoted list | TAlt of ('a tterm, 'a) annoted list | TApred of ('a tterm, 'a) annoted | TAbuilt of Hstring.t * ('a tterm, 'a) annoted list type 'a oplogic = OPand |OPor | OPimp | OPnot | OPiff | OPif of ('a tterm, 'a) annoted type 'a quant_form = { (* quantified variables that appear in the formula *) qf_bvars : (Symbols.t * Ty.t) list ; qf_upvars : (Symbols.t * Ty.t) list ; qf_triggers : (('a tterm, 'a) annoted list * bool) list ; qf_form : ('a tform, 'a) annoted } and 'a tform = | TFatom of ('a tatom, 'a) annoted | TFop of 'a oplogic * (('a tform, 'a) annoted) list | TFforall of 'a quant_form | TFexists of 'a quant_form | TFlet of (Symbols.t * Ty.t) list * Symbols.t * ('a tterm, 'a) annoted * ('a tform, 'a) annoted | TFnamed of Hstring.t * ('a tform, 'a) annoted type 'a rwt_rule = { rwt_vars : (Symbols.t * Ty.t) list; rwt_left : 'a; rwt_right : 'a } type goal_sort = Cut | Check | Thm type 'a tdecl = | TAxiom of Loc.t * string * ('a tform, 'a) annoted | TRewriting of Loc.t * string * (('a tterm, 'a) annoted rwt_rule) list | TGoal of Loc.t * goal_sort * string * ('a tform, 'a) annoted | TLogic of Loc.t * string list * plogic_type | TPredicate_def of Loc.t * string * (string * ppure_type) list * ('a tform, 'a) annoted | TFunction_def of Loc.t * string * (string * ppure_type) list * ppure_type * ('a tform, 'a) annoted | TTypeDecl of Loc.t * string list * string * body_type_decl (*****) let rec print_term fmt t = match t.c.tt_desc with | TTconst Ttrue -> fprintf fmt "true" | TTconst Tfalse -> fprintf fmt "false" | TTconst Tvoid -> fprintf fmt "void" | TTconst (Tint n) -> fprintf fmt "%s" n | TTconst (Treal n) -> fprintf fmt "%s" (Num.string_of_num n) | TTconst Tbitv s -> fprintf fmt "%s" s | TTvar s -> fprintf fmt "%a" Symbols.print s | TTapp(s,l) -> fprintf fmt "%a(%a)" Symbols.print s print_term_list l | TTinfix(t1,s,t2) -> fprintf fmt "%a %a %a" print_term t1 Symbols.print s print_term t2 | TTprefix (s, t') -> fprintf fmt "%a %a" Symbols.print s print_term t' | TTget (t1, t2) -> fprintf fmt "%a[%a]" print_term t1 print_term t2 | TTset (t1, t2, t3) -> fprintf fmt "%a[%a<-%a]" print_term t1 print_term t2 print_term t3 | TTextract (t1, t2, t3) -> fprintf fmt "%a^{%a,%a}" print_term t1 print_term t2 print_term t3 | TTconcat (t1, t2) -> fprintf fmt "%a @ %a" print_term t1 print_term t2 | TTdot (t1, s) -> fprintf fmt "%a.%s" print_term t1 (Hstring.view s) | TTrecord l -> fprintf fmt "{ "; List.iter (fun (s, t) -> fprintf fmt "%s = %a" (Hstring.view s) print_term t) l; fprintf fmt " }" | TTlet (s, t1, t2) -> fprintf fmt "let %a=%a in %a" Symbols.print s print_term t1 print_term t2 | TTnamed (lbl, t) -> fprintf fmt "%a" print_term t and print_term_list fmt = List.iter (fprintf fmt "%a," print_term) let print_atom fmt a = match a.c with | TAtrue -> fprintf fmt "True" | TAfalse -> fprintf fmt "True" | TAeq [t1; t2] -> fprintf fmt "%a = %a" print_term t1 print_term t2 | TAneq [t1; t2] -> fprintf fmt "%a <> %a" print_term t1 print_term t2 | TAle [t1; t2] -> fprintf fmt "%a <= %a" print_term t1 print_term t2 | TAlt [t1; t2] -> fprintf fmt "%a < %a" print_term t1 print_term t2 | TApred t -> print_term fmt t | TAbuilt(s, l) -> fprintf fmt "%s(%a)" (Hstring.view s) print_term_list l | _ -> assert false let string_of_op = function | OPand -> "and" | OPor -> "or" | OPimp -> "->" | OPiff -> "<->" | _ -> assert false let print_binder fmt (s, t) = fprintf fmt "%a :%a" Symbols.print s Ty.print t let print_binders fmt l = List.iter (fun c -> fprintf fmt "%a, " print_binder c) l let print_triggers fmt l = List.iter (fun (tr, _) -> fprintf fmt "%a | " print_term_list tr) l let rec print_formula fmt f = match f.c with | TFatom a -> print_atom fmt a | TFop(OPnot, [f]) -> fprintf fmt "not %a" print_formula f | TFop(OPif(t), [f1;f2]) -> fprintf fmt "if %a then %a else %a" print_term t print_formula f1 print_formula f2 | TFop(op, [f1; f2]) -> fprintf fmt "%a %s %a" print_formula f1 (string_of_op op) print_formula f2 | TFforall {qf_bvars = l; qf_triggers = t; qf_form = f} -> fprintf fmt "forall %a [%a]. %a" print_binders l print_triggers t print_formula f | _ -> assert false and print_form_list fmt = List.iter (fprintf fmt "%a" print_formula) alt-ergo-1.30/src/structures/explanation.ml0000644000175000001440000001132513014515065017403 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options module F = Formula type exp = | Literal of Literal.LT.t | Fresh of int | Bj of F.t | Dep of F.t module S = Set.Make (struct type t = exp let compare a b = match a,b with | Fresh i1, Fresh i2 -> i1 - i2 | Literal a , Literal b -> Literal.LT.compare a b | Dep e1 , Dep e2 -> Formula.compare e1 e2 | Bj e1 , Bj e2 -> Formula.compare e1 e2 | Literal _, _ -> -1 | _, Literal _ -> 1 | Fresh _, _ -> -1 | _, Fresh _ -> 1 | Dep _, _ -> 1 | _, Dep _ -> -1 end) let is_empty t = S.is_empty t type t = S.t let empty = S.empty let union s1 s2 = if s1 == s2 then s1 else S.union s1 s2 let singleton e = S.singleton e let mem e s = S.mem e s let remove e s = if S.mem e s then S.remove e s else raise Not_found let iter_atoms f s = S.iter f s let fold_atoms f s acc = S.fold f s acc (* TODO : XXX : We have to choose the smallest ??? *) let merge s1 s2 = s1 let fresh_exp = let r = ref (-1) in fun () -> incr r; Fresh !r let remove_fresh fe s = if S.mem fe s then Some (S.remove fe s) else None let add_fresh fe s = S.add fe s let print fmt ex = if Options.debug_explanations () then begin fprintf fmt "{"; S.iter (function | Literal a -> fprintf fmt "{Literal:%a}, " Literal.LT.print a | Fresh i -> Format.fprintf fmt "{Fresh:%i}" i; | Dep f -> Format.fprintf fmt "{Dep:%a}" Formula.print f | Bj f -> Format.fprintf fmt "{BJ:%a}" Formula.print f ) ex; fprintf fmt "}" end let print_proof fmt s = S.iter (fun e -> match e with | Dep f -> Format.fprintf fmt " %a@." F.print f | Bj f -> assert false (* XXX or same as Dep ? *) | Fresh i -> assert false | Literal a -> assert false ) s let formulas_of s = S.fold (fun e acc -> match e with | Dep f | Bj f -> F.Set.add f acc | Fresh _ -> acc | Literal a -> assert false (*TODO*) ) s F.Set.empty let bj_formulas_of s = S.fold (fun e acc -> match e with | Bj f -> F.Set.add f acc | Dep _ | Fresh _ -> acc | Literal a -> assert false (*TODO*) ) s F.Set.empty let rec literals_of_acc lit fs f acc = match F.view f with | F.Literal _ -> if lit then f :: acc else acc | F.Unit (f1,f2) -> let acc = literals_of_acc false fs f1 acc in literals_of_acc false fs f2 acc | F.Clause (f1, f2, _) -> let acc = literals_of_acc true fs f1 acc in literals_of_acc true fs f2 acc | F.Lemma _ -> acc | F.Skolem {F.main = f1} | F.Let {F.let_f = f1} -> literals_of_acc true fs f1 acc let literals_of ex = let fs = formulas_of ex in F.Set.fold (literals_of_acc true fs) fs [] module MI = Map.Make (struct type t = int let compare = compare end) let literals_ids_of ex = List.fold_left (fun acc f -> let i = F.id f in let m = try MI.find i acc with Not_found -> 0 in MI.add i (m + 1) acc ) MI.empty (literals_of ex) let make_deps sf = Formula.Set.fold (fun l acc -> S.add (Bj l) acc) sf S.empty let has_no_bj s = try S.iter (function Bj _ -> raise Exit | _ -> ())s; true with Exit -> false let compare = S.compare let subset = S.subset alt-ergo-1.30/src/structures/parsed.mli0000644000175000001440000000745013014515065016514 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type constant = | ConstBitv of string | ConstInt of string | ConstReal of Num.num | ConstTrue | ConstFalse | ConstVoid type pp_infix = | PPand | PPor | PPimplies | PPiff | PPlt | PPle | PPgt | PPge | PPeq | PPneq | PPadd | PPsub | PPmul | PPdiv | PPmod type pp_prefix = | PPneg | PPnot type ppure_type = | PPTint | PPTbool | PPTreal | PPTunit | PPTbitv of int | PPTvarid of string * Loc.t | PPTexternal of ppure_type list * string * Loc.t type lexpr = { pp_loc : Loc.t; pp_desc : pp_desc } and pp_desc = | PPvar of string | PPapp of string * lexpr list | PPdistinct of lexpr list | PPconst of constant | PPinfix of lexpr * pp_infix * lexpr | PPprefix of pp_prefix * lexpr | PPget of lexpr * lexpr | PPset of lexpr * lexpr * lexpr | PPdot of lexpr * string | PPrecord of (string * lexpr) list | PPwith of lexpr * (string * lexpr) list | PPextract of lexpr * lexpr * lexpr | PPconcat of lexpr * lexpr | PPif of lexpr * lexpr * lexpr | PPforall of string list * ppure_type * (lexpr list * bool) list * lexpr | PPexists of string list * ppure_type * (lexpr list * bool) list * lexpr | PPforall_named of (string * string) list * ppure_type * (lexpr list * bool) list * lexpr | PPexists_named of (string * string) list * ppure_type * (lexpr list * bool) list * lexpr | PPnamed of string * lexpr | PPlet of string * lexpr * lexpr | PPcheck of lexpr | PPcut of lexpr | PPcast of lexpr * ppure_type (* Declarations. *) type plogic_type = | PPredicate of ppure_type list | PFunction of ppure_type list * ppure_type type name_kind = Symbols.name_kind type body_type_decl = | Record of (string * ppure_type) list (* lbl : t *) | Enum of string list | Abstract type decl = | Axiom of Loc.t * string * lexpr | Rewriting of Loc.t * string * lexpr list | Goal of Loc.t * string * lexpr | Logic of Loc.t * name_kind * (string * string) list * plogic_type | Predicate_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * lexpr | Function_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * ppure_type * lexpr | TypeDecl of Loc.t * string list * string * body_type_decl type file = decl list alt-ergo-1.30/src/structures/ty.mli0000644000175000001440000000631713014515065015673 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type t = | Tint | Treal | Tbool | Tunit | Tvar of tvar | Tbitv of int | Text of t list * Hstring.t | Tfarray of t * t | Tnext of t | Tsum of Hstring.t * Hstring.t list | Trecord of trecord and tvar = { v : int ; mutable value : t option } and trecord = { mutable args : t list; name : Hstring.t; mutable lbs : (Hstring.t * t) list } module M : Map.S with type key = int type subst = t M.t val esubst : subst exception TypeClash of t*t val tunit : t val text : t list -> string -> t val tsum : string -> string list -> t val trecord : t list -> string -> (string * t) list -> t val shorten : t -> t val fresh_var : unit -> tvar val fresh_tvar : unit -> t val fresh_empty_text : unit -> t val fresh : t -> subst -> t * subst val fresh_list : t list -> subst -> t list * subst val equal : t -> t -> bool val hash : t -> int val compare : t -> t -> int val unify : t -> t -> unit val matching : subst -> t -> t -> subst val apply_subst : subst -> t -> t val instantiate : t list -> t list -> t -> t (* Applique la seconde substitution sur la premiere puis fais l'union des map avec prioritée à la première *) val union_subst : subst -> subst -> subst val compare_subst : subst -> subst -> int val equal_subst : subst -> subst -> bool val print : Format.formatter -> t -> unit val print_list : Format.formatter -> t list -> unit val print_full : Format.formatter -> t -> unit (*val printl : Format.formatter -> t list -> unit*) module Svty : Set.S with type elt = int module Set : Set.S with type elt = t val vty_of : t -> Svty.t val monomorphize: t -> t val print_subst: Format.formatter -> subst -> unit alt-ergo-1.30/src/structures/symbols.ml0000644000175000001440000001141113014515065016545 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Hashcons open Options type operator = | Plus | Minus | Mult | Div | Modulo | Concat | Extract | Get | Set | Access of Hstring.t | Record type name_kind = Ac | Constructor | Other type t = | True | False | Void | Name of Hstring.t * name_kind | Int of Hstring.t | Real of Hstring.t | Bitv of string | Op of operator | Var of Hstring.t type s = t let name ?(kind=Other) s = Name (Hstring.make s, kind) let var s = Var (Hstring.make s) let int i = Int (Hstring.make i) let real r = Real (Hstring.make r) let is_ac = function | Name(_, Ac) -> true | _ -> false let underscoring = function Var s -> Var (Hstring.make ("$"^Hstring.view s)) | _ -> assert false let compare_kind k1 k2 = match k1, k2 with | Ac , Ac -> 0 | Ac , _ -> 1 | _ , Ac -> -1 | Other, Other -> 0 | Other, _ -> 1 | _ , Other -> -1 | Constructor, Constructor -> 0 let compare s1 s2 = match s1, s2 with | Name (n1,k1), Name (n2,k2) -> let c = compare_kind k1 k2 in if c = 0 then Hstring.compare n1 n2 else c | Name _, _ -> -1 | _, Name _ -> 1 | Var n1, Var n2 -> Hstring.compare n1 n2 | Var _, _ -> -1 | _ ,Var _ -> 1 | Int i1, Int i2 -> Hstring.compare i1 i2 | Int _, _ -> -1 | _ ,Int _ -> 1 | Op(Access s1), Op(Access s2) -> Hstring.compare s1 s2 | Op(Access _), _ -> -1 | _, Op(Access _) -> 1 | _ -> Pervasives.compare s1 s2 let equal s1 s2 = compare s1 s2 = 0 let hash = function | Name (n,Ac) -> Hstring.hash n * 19 + 1 | Name (n,_) -> Hstring.hash n * 19 | Var n (*| Int n*) -> Hstring.hash n * 19 + 1 | Op (Access s) -> Hstring.hash s + 19 | s -> Hashtbl.hash s let to_string ?(show_vars=true) = function | Name (n,_) -> Hstring.view n | Var x when show_vars -> Format.sprintf "'%s'" (Hstring.view x) | Var x -> Hstring.view x | Int n -> Hstring.view n | Real n -> Hstring.view n | Bitv s -> "[|"^s^"|]" | Op Plus -> "+" | Op Minus -> "-" | Op Mult -> "*" | Op Div -> "/" | Op Modulo -> "%" | Op (Access s) -> "@Access_"^(Hstring.view s) | Op Record -> "@Record" | Op Get -> "get" | Op Set -> "set" | True -> "true" | False -> "false" | Void -> "void" | _ -> "" (*assert false*) let to_string_clean s = to_string ~show_vars:false s let to_string s = to_string ~show_vars:true s let print_clean fmt s = Format.fprintf fmt "%s" (to_string_clean s) let print fmt s = Format.fprintf fmt "%s" (to_string s) let dummy = Name (Hstring.make "_one", Other) let fresh = let cpt = ref 0 in fun s -> incr cpt; (* garder le suffixe "__" car cela influence l'ordre *) name (Format.sprintf "!?__%s%i" s (!cpt)) let is_get f = equal f (Op Get) let is_set f = equal f (Op Set) let fake_eq = name "@eq" let fake_neq = name "@neq" let fake_lt = name "@lt" let fake_le = name "@le" module Map = Map.Make(struct type t' = t type t=t' let compare=compare end) module Set = Set.Make(struct type t' = t type t=t' let compare=compare end) module Labels = Hashtbl.Make(struct type t = s let equal = equal let hash = hash end) let labels = Labels.create 100007 let add_label lbl t = Labels.replace labels t lbl let label t = try Labels.find labels t with Not_found -> Hstring.empty alt-ergo-1.30/src/structures/literal.ml0000644000175000001440000002677313014515065016532 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Hashcons open Options type 'a view = | Eq of 'a * 'a | Distinct of bool * 'a list | Builtin of bool * Hstring.t * 'a list | Pred of 'a * bool type 'a atom_view = | EQ of 'a * 'a | BT of Hstring.t * 'a list | PR of 'a | EQ_LIST of 'a list module type OrderedType = sig type t val compare : t -> t -> int val hash : t -> int val print : Format.formatter -> t -> unit val top : unit -> t val bot : unit -> t val type_info : t -> Ty.t end module type S = sig type elt type t val make : elt view -> t val view : t -> elt view val atom_view : t -> elt atom_view * bool (* is_negated ? *) val mk_eq : elt -> elt -> t val mk_distinct : bool -> elt list -> t val mk_builtin : bool -> Hstring.t -> elt list -> t val mk_pred : elt -> bool -> t val mkv_eq : elt -> elt -> elt view val mkv_distinct : bool -> elt list -> elt view val mkv_builtin : bool -> Hstring.t -> elt list -> elt view val mkv_pred : elt -> bool -> elt view val neg : t -> t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val print : Format.formatter -> t -> unit val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val uid : t -> int module Map : Map.S with type key = t module Set : Set.S with type elt = t end module Make (X : OrderedType) : S with type elt = X.t = struct type elt = X.t type atom = elt atom_view hash_consed type t = { at : atom; neg : bool; tpos : int; tneg : int } let compare a1 a2 = Pervasives.compare a1.tpos a2.tpos let equal a1 a2 = a1.tpos = a2.tpos (* XXX == *) let hash a1 = a1.tpos let uid a1 = a1.tpos let neg t = {t with neg = not t.neg; tpos = t.tneg; tneg = t.tpos} let atom_view t = t.at.node, t.neg let view t = match t.neg, t.at.node with | false, EQ(s,t) -> Eq(s,t) | true , EQ(s,t) -> Distinct(false, [s;t]) (* b false <-> not negated *) | false, EQ_LIST l -> Distinct (true,l) | true, EQ_LIST l -> Distinct (false,l) | b , PR p -> Pred(p,b) | b , BT(n,l) -> Builtin(not b, n, l) (* b true <-> not negated *) module T = struct type t' = t type t = t' let compare=compare let equal = equal let hash = hash end module Set = Set.Make(T) module Map = Map.Make(T) module Labels = Hashtbl.Make(T) let labels = Labels.create 100007 let add_label lbl t = Labels.replace labels t lbl let label t = try Labels.find labels t with Not_found -> Hstring.empty let print_list fmt = function | [] -> () | z :: l -> Format.fprintf fmt "%a" X.print z; List.iter (Format.fprintf fmt ", %a" X.print) l let ale = Hstring.make "<=" let alt = Hstring.make "<" let print fmt a = let lbl = Hstring.view (label a) in let lbl = if String.length lbl = 0 then lbl else lbl^":" in match view a with | Eq (z1, z2) -> Format.fprintf fmt "%s %a = %a" lbl X.print z1 X.print z2 | Distinct (b,(z::l)) -> let b = if b then "~ " else "" in Format.fprintf fmt "%s %s%a" lbl b X.print z; List.iter (fun x -> Format.fprintf fmt " <> %a" X.print x) l | Builtin (true, n, [v1;v2]) when Hstring.equal n ale -> Format.fprintf fmt "%s %a <= %a" lbl X.print v1 X.print v2 | Builtin (true, n, [v1;v2]) when Hstring.equal n alt -> Format.fprintf fmt "%s %a < %a" lbl X.print v1 X.print v2 | Builtin (false, n, [v1;v2]) when Hstring.equal n ale -> Format.fprintf fmt "%s %a > %a" lbl X.print v1 X.print v2 | Builtin (false, n, [v1;v2]) when Hstring.equal n alt -> Format.fprintf fmt "%s %a >= %a" lbl X.print v1 X.print v2 | Builtin (b, n, l) -> let b = if b then "" else "~" in Format.fprintf fmt "%s %s %s(%a)" lbl b (Hstring.view n) print_list l | Pred (p,b) -> Format.fprintf fmt "%s %a = %s" lbl X.print p (if b then "false" else "true") | Distinct (_, _) -> assert false module V = struct type t = elt atom_view let equal a1 a2 = match a1, a2 with | EQ(t1, t2), EQ(u1, u2) -> X.compare t1 u1 = 0 && X.compare t2 u2 = 0 | BT(n1, l1), BT(n2, l2) -> begin try Hstring.equal n1 n2 && List.for_all2 (fun x y -> X.compare x y = 0) l1 l2 with Invalid_argument _ -> false end | PR p1, PR p2 -> X.compare p1 p2 = 0 | EQ_LIST l1, EQ_LIST l2 -> begin try List.for_all2 (fun x y -> X.compare x y = 0) l1 l2 with Invalid_argument _ -> false end | _ -> false let hash a = match a with | EQ(t1, t2) -> abs (19 * (X.hash t1 + X.hash t2)) | BT(n, l) -> abs (List.fold_left (fun acc t-> acc*13 + X.hash t) (Hstring.hash n+7) l) | PR p -> abs (17 * X.hash p) (*XXX * 29 ?*) | EQ_LIST l -> abs (List.fold_left (fun acc t-> acc*31 + X.hash t) 1 l) end module H = Make_consed(V) let normalize_eq_bool t1 t2 is_neg = if X.compare t1 (X.bot()) = 0 then Pred(t2, not is_neg) else if X.compare t2 (X.bot()) = 0 then Pred(t1, not is_neg) else if X.compare t1 (X.top()) = 0 then Pred(t2, is_neg) else if X.compare t2 (X.top()) = 0 then Pred(t1, is_neg) else if is_neg then Distinct (false, [t1;t2]) (* XXX assert ? *) else Eq(t1,t2) (* should be translated into iff *) let normalize_eq t1 t2 is_neg = let c = X.compare t1 t2 in if c = 0 then Pred(X.top(), is_neg) else let t1, t2 = if c < 0 then t1, t2 else t2, t1 in if X.type_info t1 == Ty.Tbool then normalize_eq_bool t1 t2 is_neg else if is_neg then Distinct (false, [t1;t2]) (* XXX assert ? *) else Eq(t1,t2) (* should be translated into iff *) let normalize_view t = match t with | Eq(t1,t2) -> normalize_eq t1 t2 false | Distinct (b, [t1;t2]) -> normalize_eq t1 t2 (not b) | Distinct (b, l) -> Distinct (b, List.fast_sort X.compare l) | Builtin (_, _, _) | Pred (_, _) -> t let make_aux av is_neg = let at = H.hashcons av in if is_neg then {at = at; neg = is_neg; tpos = 2*at.tag+1; tneg = 2*at.tag} else {at = at; neg = is_neg; tneg = 2*at.tag+1; tpos = 2*at.tag} let make t = match normalize_view t with | Eq(t1,t2) -> make_aux (EQ(t1,t2)) false | Builtin (b,n,l) -> make_aux (BT (n,l)) (not b) | Pred (x,y) -> make_aux (PR x) y | Distinct(false, [t1;t2]) -> make_aux (EQ(t1,t2)) true | Distinct (b,l) -> make_aux (EQ_LIST l) (not b) (************) (* let mk_eq_bool t1 t2 is_neg = if X.compare t1 (X.bot()) = 0 then make_aux (PR t2) (not is_neg) else if X.compare t2 (X.bot()) = 0 then make_aux (PR t1) (not is_neg) else if X.compare t1 (X.top()) = 0 then make_aux (PR t2) is_neg else if X.compare t2 (X.top()) = 0 then make_aux (PR t1) is_neg else make_aux (EQ(t1,t2)) is_neg let mk_equa t1 t2 is_neg = let c = X.compare t1 t2 in if c = 0 then make_aux (PR (X.top())) is_neg else let t1, t2 = if c < 0 then t1, t2 else t2, t1 in if X.type_info t1 = Ty.Tbool then mk_eq_bool t1 t2 is_neg else make_aux (EQ(t1, t2)) is_neg let make t = match t with | Eq(t1,t2) -> mk_equa t1 t2 false | Distinct (b, [t1;t2]) -> mk_equa t1 t2 (not b) | Builtin (b,n,l) -> make_aux (BT (n,l)) (not b) | Distinct (_,_) -> assert false (* TODO *) | Pred (x,y) -> make_aux (PR x) y *) let mk_eq t1 t2 = make (Eq(t1,t2)) let mk_distinct is_neg tl = make (Distinct(is_neg, tl)) let mk_builtin is_pos n l = make (Builtin(is_pos, n, l)) let mk_pred t is_neg = make (Pred(t, is_neg)) let mkv_eq t1 t2 = normalize_view (Eq(t1,t2)) let mkv_distinct is_neg tl = normalize_view (Distinct(is_neg, tl)) let mkv_builtin is_pos n l = normalize_view (Builtin(is_pos, n, l)) let mkv_pred t is_neg = normalize_view (Pred(t, is_neg)) end module type S_Term = sig include S with type elt = Term.t val vrai : t val faux : t val apply_subst : Term.subst -> t -> t val terms_nonrec : t -> Term.Set.t val terms_rec : t -> Term.Set.t val vars_of : t -> Ty.t Symbols.Map.t -> Ty.t Symbols.Map.t val is_ground : t -> bool val is_in_model : t -> bool (* module SetEq : Set.S with type elt = t * Term.t * Term.t*) end module LT : S_Term = struct module L = Make(Term) include L let vrai = mk_pred Term.vrai false let faux = neg vrai let apply_subst subst a = match view a with | Pred (t1, b) -> let t1' = Term.apply_subst subst t1 in if t1 == t1' then a else make (Pred(t1', b)) | Eq (t1, t2) -> let t1' = Term.apply_subst subst t1 in let t2' = Term.apply_subst subst t2 in if t1 == t1' && t2 == t2' then a else make (Eq(t1', t2')) | Distinct (b, lt) -> let lt, same = Lists.apply (Term.apply_subst subst) lt in if same then a else make (Distinct (b, lt)) | Builtin (b, n, l) -> let l, same = Lists.apply (Term.apply_subst subst) l in if same then a else make (Builtin(b, n, l)) let terms_nonrec a = match atom_view a with | EQ(a,b), _ -> Term.Set.add a (Term.Set.singleton b) | PR a, _ -> Term.Set.singleton a | BT (_,l), _ | EQ_LIST l, _ -> List.fold_left (fun z t -> Term.Set.add t z) Term.Set.empty l let terms_rec a = Term.Set.fold (fun t z -> Term.subterms z t)(terms_nonrec a) Term.Set.empty module SM = Symbols.Map let vars_of a acc = Term.Set.fold Term.vars_of (terms_nonrec a) acc let is_ground a = Term.Set.for_all Term.is_ground (terms_nonrec a) let is_in_model l = match view l with | Eq (t1, t2) -> Term.is_in_model t1 || Term.is_in_model t2 | Distinct (_, tl) | Builtin (_, _, tl) -> List.exists Term.is_in_model tl | Pred (t1, b) -> Term.is_in_model t1 let apply_subst s a = if Options.timers() then try Options.exec_timer_start Timers.M_Literal Timers.F_apply_subst; let res = apply_subst s a in Options.exec_timer_pause Timers.M_Literal Timers.F_apply_subst; res with e -> Options.exec_timer_pause Timers.M_Literal Timers.F_apply_subst; raise e else apply_subst s a end alt-ergo-1.30/src/structures/ty.ml0000644000175000001440000003223313014515065015516 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Hashcons open Format open Options type t = | Tint | Treal | Tbool | Tunit | Tvar of tvar | Tbitv of int | Text of t list * Hstring.t | Tfarray of t * t | Tnext of t | Tsum of Hstring.t * Hstring.t list | Trecord of trecord and tvar = { v : int ; mutable value : t option } and trecord = { mutable args : t list; name : Hstring.t; mutable lbs : (Hstring.t * t) list } exception TypeClash of t*t exception Shorten of t (*** pretty print ***) let print full = let h = Hashtbl.create 17 in let rec print fmt = function | Tint -> fprintf fmt "int" | Treal -> fprintf fmt "real" | Tbool -> fprintf fmt "bool" | Tunit -> fprintf fmt "unit" | Tbitv n -> fprintf fmt "bitv[%d]" n | Tvar{v=v ; value = None} -> fprintf fmt "'a_%d" v | Tvar{v=v ; value = Some (Trecord {args=l; name=n} as t) } -> if Hashtbl.mem h v then fprintf fmt "%a %s" print_list l (Hstring.view n) else (Hashtbl.add h v (); (*fprintf fmt "('a_%d->%a)" v print t *) print fmt t) | Tvar{v=v ; value = Some t} -> (*fprintf fmt "('a_%d->%a)" v print t *) print fmt t | Text(l, s) -> fprintf fmt "%a %s" print_list l (Hstring.view s) | Tfarray (t1, t2) -> fprintf fmt "(%a,%a) farray" print t1 print t2 | Tnext t -> fprintf fmt "%a next" print t | Tsum(s, _) -> fprintf fmt "%s" (Hstring.view s) | Trecord {args=lv; name=n; lbs=lbls} -> fprintf fmt "%a %s" print_list lv (Hstring.view n); if full then begin fprintf fmt " = {"; let first = ref true in List.iter (fun (s, t) -> fprintf fmt "%s%s : %a" (if !first then "" else "; ") (Hstring.view s) print t; first := false ) lbls; fprintf fmt "}" end and print_list fmt = function | [] -> () | [t] -> fprintf fmt "%a " print t | t::l -> fprintf fmt "(%a" print t; List.iter (fprintf fmt ", %a" print) l; fprintf fmt ")" in print, print_list let print_list = snd (print false) let print_full = fst (print true) let print = fst (print false) (* smart constructors *) let tunit = Text ([],Hstring.make "unit") let text l s = Text (l,Hstring.make s) let tsum s lc = Tsum (Hstring.make s, List.map Hstring.make lc) let trecord lv n lbs = let lbs = List.map (fun (l,ty) -> Hstring.make l, ty) lbs in let lbs = List.sort (fun (l1, _) (l2, _) -> Hstring.compare l1 l2) lbs in Trecord { args = lv; name = Hstring.make n; lbs = lbs} let rec shorten ty = match ty with | Tvar {value=None} -> ty | Tvar {value=Some(Tvar{value=None} as t')} -> t' | Tvar ({value=Some(Tvar t2)} as t1) -> t1.value <- t2.value; shorten ty | Tvar {v = n; value = Some t'} -> shorten t' | Text (l,s) -> let l, same = Lists.apply shorten l in if same then ty else Text(l,s) | Tfarray (t1,t2) -> let t1' = shorten t1 in let t2' = shorten t2 in if t1 == t1' && t2 == t2' then ty else Tfarray(t1', t2') | Trecord r -> r.args <- List.map shorten r.args; r.lbs <- List.map (fun (lb, ty) -> lb, shorten ty) r.lbs; ty | Tnext t1 -> let t1' = shorten t1 in if t1 == t1' then ty else Tnext t1' | Tint | Treal | Tbool | Tunit | Tbitv _ | Tsum (_, _) -> ty let fresh_var = let cpt = ref (-1) in fun () -> incr cpt; {v= !cpt ; value = None } let fresh_tvar () = Tvar (fresh_var ()) let fresh_empty_text = let cpt = ref (-1) in fun () -> incr cpt; text [] ("'_c"^(string_of_int !cpt)) let rec hash t = match t with | Tvar{v=v} -> v | Text(l,s) -> abs (List.fold_left (fun acc x-> acc*19 + hash x) (Hstring.hash s) l) | Tfarray (t1,t2) -> 19 * (hash t1) + 23 * (hash t2) | Trecord { args = args; name = s; lbs = lbs} -> let h = List.fold_left (fun h ty -> 27 * h + hash ty) (Hstring.hash s) args in let h = List.fold_left (fun h (lb, ty) -> 23 * h + 19 * (Hstring.hash lb) + hash ty) (abs h) lbs in abs h | Tsum (s, l) -> abs (Hstring.hash s) (*we do not hash constructors*) | _ -> Hashtbl.hash t let rec equal t1 t2 = match shorten t1 , shorten t2 with | Tvar{v=v1}, Tvar{v=v2} -> v1 = v2 | Text(l1, s1), Text(l2, s2) -> (try s1.tag = s2.tag && List.for_all2 equal l1 l2 with Invalid_argument _ -> false) | Tfarray (ta1, ta2), Tfarray (tb1, tb2) -> equal ta1 tb1 && equal ta2 tb2 | Tsum (s1, _), Tsum (s2, _) -> Hstring.equal s1 s2 | Trecord {args=a1;name=s1;lbs=l1}, Trecord {args=a2;name=s2;lbs=l2} -> begin try Hstring.equal s1 s2 && List.for_all2 equal a1 a2 && List.for_all2 (fun (l1, ty1) (l2, ty2) -> Hstring.equal l1 l2 && equal ty1 ty2) l1 l2 with Invalid_argument _ -> false end | Tint, Tint | Treal, Treal | Tbool, Tbool | Tunit, Tunit -> true | Tbitv n1, Tbitv n2 -> n1 =n2 | Tnext t1, Tnext t2 -> equal t1 t2 | _ -> false let rec compare t1 t2 = match shorten t1 , shorten t2 with | Tvar{v=v1} , Tvar{v=v2} -> Pervasives.compare v1 v2 | Tvar _, _ -> -1 | _ , Tvar _ -> 1 | Text(l1, s1) , Text(l2, s2) -> let c = Hstring.compare s1 s2 in if c<>0 then c else compare_list l1 l2 | Text _, _ -> -1 | _ , Text _ -> 1 | Tfarray (ta1,ta2), Tfarray (tb1,tb2) -> let c = compare ta1 tb1 in if c<>0 then c else compare ta2 tb2 | Tfarray _, _ -> -1 | _ , Tfarray _ -> 1 | Tsum(s1, _), Tsum(s2, _) -> Hstring.compare s1 s2 | Tsum _, _ -> -1 | _ , Tsum _ -> 1 | Trecord {args=a1;name=s1;lbs=l1},Trecord {args=a2;name=s2;lbs=l2} -> let c = Hstring.compare s1 s2 in if c <> 0 then c else let c = compare_list a1 a2 in if c <> 0 then c else let l1, l2 = List.map snd l1, List.map snd l2 in compare_list l1 l2 | Trecord _, _ -> -1 | _ , Trecord _ -> 1 | t1 , t2 -> Pervasives.compare t1 t2 and compare_list l1 l2 = match l1, l2 with | [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 | x::ll1 , y::ll2 -> let c = compare x y in if c<>0 then c else compare_list ll1 ll2 let occurs {v=n} t = let rec occursrec = function Tvar {v=m} -> n=m | Text(l,_) -> List.exists occursrec l | Tfarray (t1,t2) -> occursrec t1 || occursrec t2 | _ -> false in occursrec t (*** destructive unification ***) let rec unify t1 t2 = let t1 = shorten t1 in let t2 = shorten t2 in match t1 , t2 with Tvar ({v=n;value=None} as tv1), Tvar {v=m;value=None} -> if n<>m then tv1.value <- Some t2 | _ , Tvar ({value=None} as tv) -> if (occurs tv t1) then raise (TypeClash(t1,t2)); tv.value <- Some t1 | Tvar ({value=None} as tv) , _ -> if (occurs tv t2) then raise (TypeClash(t1,t2)); tv.value <- Some t2 | Text(l1,s1) , Text(l2,s2) when Hstring.equal s1 s2 -> List.iter2 unify l1 l2 | Tfarray (ta1,ta2), Tfarray (tb1,tb2) -> unify ta1 tb1;unify ta2 tb2 | Trecord r1, Trecord r2 when Hstring.equal r1.name r2.name -> List.iter2 unify r1.args r2.args | Tsum(s1, _) , Tsum(s2, _) when Hstring.equal s1 s2 -> () | Tint, Tint | Tbool, Tbool | Treal, Treal | Tunit, Tunit -> () | Tbitv n , Tbitv m when m=n -> () | _ , _ -> raise (TypeClash(t1,t2)) (*** matching with a substitution mechanism ***) module M = Map.Make(struct type t=int let compare = Pervasives.compare end) type subst = t M.t let esubst = M.empty let rec matching s pat t = match pat , t with | Tvar {v=n;value=None} , _ -> (try if not (equal (M.find n s) t) then raise (TypeClash(pat,t)); s with Not_found -> M.add n t s) | Tvar {value=_}, _ -> raise (Shorten pat) | Text (l1,s1) , Text (l2,s2) when Hstring.equal s1 s2 -> List.fold_left2 matching s l1 l2 | Tfarray (ta1,ta2), Tfarray (tb1,tb2) -> matching (matching s ta1 tb1) ta2 tb2 | Trecord r1, Trecord r2 when Hstring.equal r1.name r2.name -> let s = List.fold_left2 matching s r1.args r2.args in List.fold_left2 (fun s (_, p) (_, ty) -> matching s p ty) s r1.lbs r2.lbs | Tsum (s1, _), Tsum (s2, _) when Hstring.equal s1 s2 -> s | Tint , Tint | Tbool , Tbool | Treal , Treal | Tunit, Tunit -> s | Tbitv n , Tbitv m when n=m -> s | _ , _ -> raise (TypeClash(pat,t)) let rec apply_subst s ty = match ty with | Tvar {v=n} -> (try M.find n s with Not_found -> ty) | Text (l,e) -> let l, same = Lists.apply (apply_subst s) l in if same then ty else Text(l, e) | Tfarray (t1,t2) -> let t1' = apply_subst s t1 in let t2' = apply_subst s t2 in if t1 == t1' && t2 == t2' then ty else Tfarray (t1', t2') | Trecord r -> let lbs, same1 = Lists.apply_right (apply_subst s) r.lbs in let args, same2 = Lists.apply (apply_subst s) r.args in if same1 && same2 then ty else Trecord {args = args; name = r.name; lbs = lbs} | Tnext t -> let t' = apply_subst s t in if t == t' then ty else Tnext t' | Tint | Treal | Tbool | Tunit | Tbitv _ | Tsum (_, _) -> ty let instantiate lvar lty ty = let s = List.fold_left2 (fun s x t -> match x with | Tvar {v=n} -> M.add n t s | _ -> assert false) M.empty lvar lty in apply_subst s ty let union_subst s1 s2 = M.fold (fun k x s2 -> M.add k x s2) (M.map (apply_subst s2) s1) s2 let compare_subst = M.compare Pervasives.compare let equal_subst = M.equal Pervasives.(=) let rec fresh ty subst = match ty with | Tvar {v=x} -> begin try M.find x subst, subst with Not_found -> let nv = Tvar (fresh_var()) in nv, M.add x nv subst end | Text (args, n) -> let args, subst = fresh_list args subst in Text (args, n), subst | Tfarray (ty1, ty2) -> let ty1, subst = fresh ty1 subst in let ty2, subst = fresh ty2 subst in Tfarray (ty1, ty2), subst | Trecord {args = args; name = n; lbs = lbs} -> let args, subst = fresh_list args subst in let lbs, subst = List.fold_right (fun (x,ty) (lbs, subst) -> let ty, subst = fresh ty subst in (x, ty)::lbs, subst) lbs ([], subst) in Trecord { args = args; name = n; lbs = lbs}, subst | Tnext ty -> let ty, subst = fresh ty subst in Tnext ty, subst | t -> t, subst and fresh_list lty subst = List.fold_right (fun ty (lty, subst) -> let ty, subst = fresh ty subst in ty::lty, subst) lty ([], subst) module Svty = Set.Make(struct type t = int let compare = Pervasives.compare end) module Set = Set.Make(struct type t' = t type t = t' let compare = compare end) let vty_of t = let rec vty_of_rec acc t = let t = shorten t in match t with | Tvar { v = i ; value = None } -> Svty.add i acc | Text(l,_) -> List.fold_left vty_of_rec acc l | Tfarray (t1,t2) -> vty_of_rec (vty_of_rec acc t1) t2 | Trecord {args = args; name = s; lbs = lbs} -> let acc = List.fold_left vty_of_rec acc args in List.fold_left (fun acc (_, ty) -> vty_of_rec acc ty) acc lbs | _ -> acc in vty_of_rec Svty.empty t let rec monomorphize ty = match ty with | Tint | Treal | Tbool | Tunit | Tbitv _ | Tsum _ -> ty | Text (tyl,hs) -> Text (List.map monomorphize tyl, hs) | Trecord {args = tylv; name = n; lbs = tylb} -> let m_tylv = List.map monomorphize tylv in let m_tylb = List.map (fun (lb, ty_lb) -> lb, monomorphize ty_lb) tylb in Trecord {args = m_tylv; name = n; lbs = m_tylb} | Tfarray (ty1,ty2) -> Tfarray (monomorphize ty1,monomorphize ty2) | Tnext ty -> Tnext (monomorphize ty) | Tvar {v=v; value=None} -> text [] ("'_c"^(string_of_int v)) | Tvar ({value=Some ty1} as r) -> Tvar { r with value = Some (monomorphize ty1)} let print_subst fmt sbt = M.iter (fun n ty -> fprintf fmt "%d -> %a" n print ty) sbt; fprintf fmt "@?" alt-ergo-1.30/src/structures/commands.mli0000644000175000001440000000364113014515065017035 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Parsed open Typed (* Sat entry *) type sat_decl_aux = | Assume of Formula.t * bool | PredDef of Formula.t * string (*name of the predicate*) | RwtDef of (Term.t rwt_rule) list | Query of string * Formula.t * Literal.LT.t list * goal_sort type sat_tdecl = { st_loc : Loc.t; st_decl : sat_decl_aux } alt-ergo-1.30/src/structures/term.ml0000644000175000001440000002346313014515065016036 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Hashcons open Options module Sy = Symbols type view = {f: Sy.t ; xs: t list; ty: Ty.t; depth: int; tag: int; vars : Ty.t Sy.Map.t Lazy.t; vty : Ty.Svty.t Lazy.t} and t = view module Subst = struct include Symbols.Map let print pr_elt fmt sbt = iter (fun k v -> fprintf fmt "%a -> %a " Sy.print k pr_elt v) sbt end type subst = t Subst.t * Ty.subst module H = struct type t = view let equal t1 t2 = try Sy.equal t1.f t2.f && List.for_all2 (==) t1.xs t2.xs && Ty.equal t1.ty t2.ty with Invalid_argument _ -> false let hash t = abs (List.fold_left (fun acc x-> acc*19 +x.tag) (Sy.hash t.f + Ty.hash t.ty) t.xs) let tag tag x = {x with tag = tag} end module T = Make(H) let view t = t let rec print_silent fmt t = let {f=x;xs=l;ty=ty} = view t in match x, l with | Sy.Op Sy.Get, [e1; e2] -> fprintf fmt "%a[%a]" print e1 print e2 | Sy.Op Sy.Set, [e1; e2; e3] -> fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 | Sy.Op Sy.Concat, [e1; e2] -> fprintf fmt "%a@@%a" print e1 print e2 | Sy.Op Sy.Extract, [e1; e2; e3] -> fprintf fmt "%a^{%a,%a}" print e1 print e2 print e3 | Sy.Op (Sy.Access field), [e] -> fprintf fmt "%a.%s" print e (Hstring.view field) | Sy.Op (Sy.Record), _ -> begin match ty with | Ty.Trecord {Ty.lbs=lbs} -> assert (List.length l = List.length lbs); fprintf fmt "{"; ignore (List.fold_left2 (fun first (field,_) e -> fprintf fmt "%s%s = %a" (if first then "" else "; ") (Hstring.view field) print e; false ) true lbs l); fprintf fmt "}"; | _ -> assert false end | Sy.Op op, [e1; e2] -> fprintf fmt "(%a %a %a)" print e1 Sy.print x print e2 | _, [] -> fprintf fmt "%a" Sy.print x | _, _ -> fprintf fmt "%a(%a)" Sy.print x print_list l and print_verbose fmt t = fprintf fmt "(%a : %a)" print_silent t Ty.print (view t).ty and print fmt t = if Options.debug () then print_verbose fmt t else print_silent fmt t and print_list_sep sep fmt = function | [] -> () | [t] -> print fmt t | t::l -> Format.fprintf fmt "%a%s%a" print t sep (print_list_sep sep) l and print_list fmt = print_list_sep "," fmt (* * We keep true and false as repr * ordering is influenced by depth * otherwise, we compare tag2 - tag1 so that fresh vars will be smaller *) let compare t1 t2 = if t1 == t2 then 0 else let c = t1.depth - t2.depth in if c <> 0 then c else match (view t1).f, (view t2).f with | (Sy.True | Sy.False ), (Sy.True | Sy.False) -> t2.tag - t1.tag | (Sy.True | Sy.False ), _ -> -1 | _, (Sy.True | Sy.False ) -> 1 | _ -> t2.tag - t1.tag let sort = List.sort compare let merge_maps acc b = Sy.Map.merge (fun sy a b -> match a, b with | None, None -> assert false | Some _, None -> a | _ -> b ) acc b let vars_of_make s l ty = lazy ( match s, l with | Sy.Var _, [] -> Sy.Map.singleton s ty | Sy.Var _, _ -> assert false | _, [] -> Sy.Map.empty | _, e::r -> List.fold_left (fun s t -> merge_maps s (Lazy.force t.vars)) (Lazy.force e.vars) r ) let vty_of_make l ty = lazy ( List.fold_left (fun acc t -> Ty.Svty.union acc (Lazy.force t.vty)) (Ty.vty_of ty) l ) let make s l ty = let d = 1 + List.fold_left (fun z t -> max z t.depth) 0 l in let vars = vars_of_make s l ty in let vty = vty_of_make l ty in T.hashcons {f=s; xs=l; ty=ty; depth=d; tag= -42; vars; vty} let fresh_name ty = make (Sy.name (Hstring.fresh_string())) [] ty let is_fresh t = match view t with | {f=Sy.Name(hs,_);xs=[]} -> Hstring.is_fresh_string (Hstring.view hs) | _ -> false let is_fresh_skolem t = match view t with | {f=Sy.Name(hs,_)} -> Hstring.is_fresh_skolem (Hstring.view hs) | _ -> false let shorten t = let {f=f;xs=xs;ty=ty} = view t in make f xs (Ty.shorten ty) let vrai = make (Sy.True) [] Ty.Tbool let faux = make (Sy.False) [] Ty.Tbool let void = make (Sy.Void) [] Ty.Tunit let positive_int i = make (Sy.int i) [] Ty.Tint let int i = let len = String.length i in assert (len >= 1); match i.[0] with | '-' -> assert (len >= 2); let pi = String.sub i 1 (len - 1) in make (Sy.Op Sy.Minus) [ positive_int "0"; positive_int pi ] Ty.Tint | _ -> positive_int i let positive_real i = make (Sy.real i) [] Ty.Treal let real r = let len = String.length r in assert (len >= 1); match r.[0] with | '-' -> assert (len >= 2); let pi = String.sub r 1 (len - 1) in make (Sy.Op Sy.Minus) [ positive_real "0"; positive_real pi ] Ty.Treal | _ -> positive_real r let bitv bt ty = make (Sy.Bitv bt) [] ty let is_int t = (view t).ty == Ty.Tint let is_real t = (view t).ty == Ty.Treal let equal t1 t2 = t1 == t2 let hash t = t.tag let pred t = make (Sy.Op Sy.Minus) [t;int "1"] Ty.Tint module Set = Set.Make(struct type t' = t type t=t' let compare=compare end) module Map = Map.Make(struct type t' = t type t=t' let compare=compare end) let vars_of t acc = merge_maps acc (Lazy.force t.vars) let vty_of t = Lazy.force t.vty module Hsko = Hashtbl.Make(H) let gen_sko ty = make (Sy.fresh "@sko") [] ty let is_skolem_cst v = try Pervasives.(=) (String.sub (Sy.to_string v.f) 0 4) "_sko" with Invalid_argument _ -> false let find_skolem = let hsko = Hsko.create 17 in fun v ty -> if is_skolem_cst v then try Hsko.find hsko v with Not_found -> let c = gen_sko ty in Hsko.add hsko v c; c else v let is_ground t = Symbols.Map.is_empty (vars_of t Sy.Map.empty) && Ty.Svty.is_empty (vty_of t) let rec apply_subst (s_t,s_ty) t = let {f=f;xs=xs;ty=ty; vars; vty} = view t in if is_ground t then t else let vars = Lazy.force vars in let vty = Lazy.force vty in let s_t = Sy.Map.filter (fun sy _ -> Sy.Map.mem sy vars) s_t in let s_ty = Ty.M.filter (fun id _ -> Ty.Svty.mem id vty) s_ty in if s_t == Sy.Map.empty && s_ty == Ty.M.empty then t else try let v = Sy.Map.find f s_t in find_skolem v ty with Not_found -> let s = s_t, s_ty in let xs', same = Lists.apply (apply_subst s) xs in let ty' = Ty.apply_subst s_ty ty in if same && ty == ty' then t else make f xs' ty' let compare_subst (s_t1, s_ty1) (s_t2, s_ty2) = let c = Ty.compare_subst s_ty1 s_ty2 in if c<>0 then c else Sy.Map.compare compare s_t1 s_t2 let equal_subst (s_t1, s_ty1) (s_t2, s_ty2) = Ty.equal_subst s_ty1 s_ty2 || Sy.Map.equal equal s_t1 s_t2 let fold_subst_term f (s,_) acc = Sy.Map.fold f s acc let union_subst (s_t1, s_ty1) ((s_t2, s_ty2) as subst) = let s_t = Sy.Map.fold (fun k x s2 -> Sy.Map.add k x s2) (Sy.Map.map (apply_subst subst) s_t1) s_t2 in let s_ty = Ty.union_subst s_ty1 s_ty2 in s_t, s_ty let rec subterms acc t = let {xs=xs} = view t in List.fold_left subterms (Set.add t acc) xs module Labels = Hashtbl.Make(H) let labels = Labels.create 100007 let add_label lbl t = Labels.replace labels t lbl let label t = try Labels.find labels t with Not_found -> Hstring.empty let label_model h = try Pervasives.(=) (String.sub (Hstring.view h) 0 6) "model:" with Invalid_argument _ -> false let rec is_in_model_rec depth { f = f; xs = xs } = let lb = Symbols.label f in (label_model lb && (try let md = Scanf.sscanf (Hstring.view lb) "model:%d" (fun x -> x) in depth <= md with Scanf.Scan_failure _ | End_of_file-> true)) || List.exists (is_in_model_rec (depth +1)) xs let is_in_model t = label_model (label t) || is_in_model_rec 0 t let is_labeled t = not (Hstring.equal (label t) Hstring.empty) let print_tagged_classes fmt = List.iter (fun cl -> let cl = List.filter is_labeled (Set.elements cl) in if cl != [] then fprintf fmt "\n{ %a }" (print_list_sep " , ") cl) let type_info t = t.ty let top () = vrai let bot () = faux let apply_subst s t = if Options.timers() then try Options.exec_timer_start Timers.M_Term Timers.F_apply_subst; let res = apply_subst s t in Options.exec_timer_pause Timers.M_Term Timers.F_apply_subst; res with e -> Options.exec_timer_pause Timers.M_Term Timers.F_apply_subst; raise e else apply_subst s t alt-ergo-1.30/src/theories/0000755000175000001440000000000013014515065014124 5ustar rtusersalt-ergo-1.30/src/theories/combine.mli0000644000175000001440000000341613014515065016247 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module Shostak : Sig.X module Use : Use.S with type r = Shostak.r module Uf : Uf.S with type r = Shostak.r module Relation : Sig.RELATION with type r = Shostak.r and type uf = Uf.t alt-ergo-1.30/src/theories/theory.ml0000644000175000001440000005274113014515065016001 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig open Exception module X = Combine.Shostak module Ex = Explanation module SetF = Formula.Set module T = Term module A = Literal module LR = A.Make(struct type t = X.r let compare = X.str_cmp include X end) module SetT = Term.Set module Sy = Symbols module CC_X = Ccx.Main module type S = sig type t val empty : unit -> t (* the first int is the decision level (dlvl) and the second one is the propagation level (plvl). The facts (first argument) are sorted in decreasing order with respect to (dlvl, plvl) *) val assume : ?ordered:bool -> (Literal.LT.t * Explanation.t * int * int) list -> t -> t * Term.Set.t * int val query : Literal.LT.t -> t -> answer val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val print_model : Format.formatter -> t -> unit val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val extract_ground_terms : t -> Term.Set.t val get_real_env : t -> Ccx.Main.t val get_case_split_env : t -> Ccx.Main.t val do_case_split : t -> t * Term.Set.t val add_term : t -> Term.t -> add_in_cs:bool -> t val compute_concrete_model : t -> t end module Main_Default : S = struct (*BISECT-IGNORE-BEGIN*) module Debug = struct let subterms_of_assumed l = List.fold_left (List.fold_left (fun st (a, _, _) -> Term.Set.union st (A.LT.terms_rec a)) )SetT.empty l let types_of_subterms st = SetT.fold (fun t acc -> Ty.Set.add (T.type_info t) acc) st Ty.Set.empty let generalize_types ty1 ty2 = match ty1, ty2 with | Ty.Tvar _, _ -> ty1 | _, Ty.Tvar _ -> ty2 | _ -> Ty.fresh_tvar () let logics_of_assumed st = SetT.fold (fun t mp -> match T.view t with | {T.f = Sy.Name (hs, ((Sy.Ac | Sy.Other) as is_ac)); xs=xs; ty=ty} -> let xs = List.map T.type_info xs in let xs, ty = try let xs', ty', is_ac' = Hstring.Map.find hs mp in assert (is_ac == is_ac'); let ty = generalize_types ty ty' in let xs = try List.map2 generalize_types xs xs' with _ -> assert false in xs, ty with Not_found -> xs, ty in Hstring.Map.add hs (xs, ty, is_ac) mp | _ -> mp )st Hstring.Map.empty let types_of_assumed sty = let open Ty in Ty.Set.fold (fun ty mp -> match ty with | Tint | Treal | Tbool | Tunit | Tbitv _ | Tfarray _ -> mp | Tvar _ | Tnext _ -> assert false | Text (_, hs) | Tsum (hs, _) | Trecord {name=hs} when Hstring.Map.mem hs mp -> mp | Text (l, hs) -> let l = List.map (fun _ -> Ty.fresh_tvar()) l in Hstring.Map.add hs (Text(l, hs)) mp | Tsum (hs, l) -> Hstring.Map.add hs (Tsum(hs, l)) mp | Trecord {args; name; lbs} -> (* cannot do better for records ? *) Hstring.Map.add name ty mp )sty Hstring.Map.empty let print_types_decls types = let open Ty in Hstring.Map.iter (fun _ ty -> match ty with | Tint | Treal | Tbool | Tunit | Tbitv _ | Tfarray _ -> () | Tvar _ | Tnext _ -> assert false | Text _ -> fprintf fmt "@.type %a@." Ty.print ty | Tsum (_, l) -> fprintf fmt "@.type %a = " Ty.print ty; begin match l with | [] -> assert false | e::l -> fprintf fmt "%s" (Hstring.view e); List.iter (fun e -> fprintf fmt " | %s" (Hstring.view e)) l; fprintf fmt "@." end | Trecord {Ty.lbs} -> fprintf fmt "@.type %a = " Ty.print ty; begin match lbs with | [] -> assert false | (lbl, ty)::l -> fprintf fmt "{ %s : %a" (Hstring.view lbl) Ty.print ty; List.iter (fun (lbl, ty) -> fprintf fmt " ; %s : %a" (Hstring.view lbl) Ty.print ty) l; fprintf fmt " }@." end )types; fprintf fmt "@." let print_arrow_type fmt xs = match xs with | [] -> () | e :: l -> fprintf fmt "%a" Ty.print e; List.iter (fprintf fmt ", %a" Ty.print) l; fprintf fmt " -> " let print_logics logics = Hstring.Map.iter (fun hs (xs, ty, is_ac) -> fprintf fmt "logic %s%s : %a%a@.@." (if is_ac == Sy.Ac then "ac " else "") (Hstring.view hs) print_arrow_type xs Ty.print ty )logics let print_declarations l = let st = subterms_of_assumed l in let sty = types_of_subterms st in let types = types_of_assumed sty in let logics = logics_of_assumed st in print_types_decls types; print_logics logics let assumed = let cpt = ref 0 in fun l -> if debug_cc () then begin fprintf fmt "[cc] Assumed facts (in this order):@.@."; print_declarations l; incr cpt; fprintf fmt "@.goal g_%d :@." !cpt; List.iter (fun l -> fprintf fmt "@.(*call to assume*)@."; match List.rev l with | [] -> assert false | (a,dlvl,plvl)::l -> fprintf fmt "( (* %d , %d *) %a " dlvl plvl Literal.LT.print a; List.iter (fun (a, dlvl, plvl) -> fprintf fmt " and@. (* %d , %d *) %a " dlvl plvl Literal.LT.print a ) l; fprintf fmt " ) ->@." ) (List.rev l); fprintf fmt "false@."; end let theory_of k = match k with | Th_arith -> "Th_arith " | Th_sum -> "Th_sum " | Th_arrays -> "Th_arrays" | Th_UF -> "Th_UF" let made_choices fmt choices = match choices with | [] -> () | _ -> fprintf fmt "Stack of choices:@."; List.iter (fun (rx, lit_orig, _, ex) -> match lit_orig with | CS(k, sz) -> fprintf fmt " > %s cs: %a (because %a)@." (theory_of k) LR.print (LR.make rx) Ex.print ex | NCS(k, sz) -> fprintf fmt " > %s ncs: %a (because %a)@." (theory_of k) LR.print (LR.make rx) Ex.print ex | _ -> assert false )choices; fprintf fmt "==============================================@." let begin_case_split choices = if debug_split () then fprintf fmt "============= Begin CASE-SPLIT ===============@.%a@." made_choices choices let end_case_split choices = if debug_split () then fprintf fmt "============= End CASE-SPLIT =================@.%a@." made_choices choices let split_size sz = if debug_split () then fprintf fmt ">size case-split: %s@." (Numbers.Q.to_string sz) let print_lr_view fmt ch = LR.print fmt (LR.make ch) let split_backtrack neg_c ex_c = if debug_split () then fprintf fmt "[case-split] I backtrack on %a : %a@." print_lr_view neg_c Ex.print ex_c let split_assume c ex_c = if debug_split () then fprintf fmt "[case-split] I assume %a : %a@." print_lr_view c Ex.print ex_c let split_backjump c dep = if debug_split () then fprintf fmt "[case-split] I backjump on %a : %a@." print_lr_view c Ex.print dep let query a = if debug_cc () then fprintf fmt "[cc] query : %a@." A.LT.print a let split_sat_contradicts_cs filt_choices = if debug_split () then fprintf fmt "[case-split] The SAT contradicts CS! I'll replay choices@.%a@." made_choices filt_choices end (*BISECT-IGNORE-END*) type choice_sign = | CPos of Ex.exp (* The explication of this choice *) | CNeg (* The choice has been already negated *) type t = { assumed : (Literal.LT.t * int * int) list list; cs_pending_facts : (Literal.LT.t * Ex.t * int * int) list list; terms : Term.Set.t; gamma : CC_X.t; gamma_finite : CC_X.t; choices : (X.r Literal.view * lit_origin * choice_sign * Ex.t) list; (** the choice, the size, choice_sign, the explication set, the explication for this choice. *) } let look_for_sat ?(bad_last=No) ch t base_env l ~for_model = let rec aux ch bad_last dl base_env li = Options.exec_thread_yield (); match li, bad_last with | [], _ -> begin Options.tool_req 3 "TR-CCX-CS-Case-Split"; let l, base_env = CC_X.case_split base_env for_model in match l with | [] -> { t with gamma_finite = base_env; choices = List.rev dl }, ch | l -> let l = List.map (fun (c, is_cs, size) -> Options.incr_cs_steps(); let exp = Ex.fresh_exp () in let ex_c_exp = if is_cs then Ex.add_fresh exp Ex.empty else Ex.empty in (* A new explanation in order to track the choice *) (c, size, CPos exp, ex_c_exp)) l in aux ch No dl base_env l end | ((c, lit_orig, CNeg, ex_c) as a)::l, _ -> let facts = CC_X.empty_facts () in CC_X.add_fact facts (LSem c,ex_c,lit_orig); let base_env, ch = CC_X.assume_literals base_env ch facts in aux ch bad_last (a::dl) base_env l (** This optimisation is not correct with the current explanation *) (* | [(c, lit_orig, CPos exp, ex_c)], Yes (dep,_) -> *) (* let neg_c = CC_X.Rel.choice_mk_not c in *) (* let ex_c = Ex.union ex_c dep in *) (* Debug.split_backtrack neg_c ex_c; *) (* aux ch No dl base_env [neg_c, Numbers.Q.Int 1, CNeg, ex_c] *) | ((c, lit_orig, CPos exp, ex_c_exp) as a)::l, _ -> try Debug.split_assume c ex_c_exp; let facts = CC_X.empty_facts () in CC_X.add_fact facts (LSem c, ex_c_exp, lit_orig); let base_env, ch = CC_X.assume_literals base_env ch facts in Options.tool_req 3 "TR-CCX-CS-Normal-Run"; aux ch bad_last (a::dl) base_env l with Exception.Inconsistent (dep, classes) -> match Ex.remove_fresh exp dep with | None -> (* The choice doesn't participate to the inconsistency *) Debug.split_backjump c dep; Options.tool_req 3 "TR-CCX-CS-Case-Split-Conflict"; raise (Exception.Inconsistent (dep, classes)) | Some dep -> Options.tool_req 3 "TR-CCX-CS-Case-Split-Progress"; (* The choice participates to the inconsistency *) let neg_c = LR.view (LR.neg (LR.make c)) in let lit_orig = match lit_orig with | CS(k, sz) -> NCS(k, sz) | _ -> assert false in Debug.split_backtrack neg_c dep; if bottom_classes () then printf "bottom (case-split):%a\n@." Term.print_tagged_classes classes; aux ch No dl base_env [neg_c, lit_orig, CNeg, dep] in aux ch bad_last (List.rev t.choices) base_env l (* remove old choices involving fresh variables that are no longer in UF *) let filter_choice uf (ra,_,_,_) = let l = match ra with | A.Eq(r1, r2) -> [r1; r2] | A.Distinct (_, l) -> l | A.Builtin (_,_, l) -> l | A.Pred(p, _) -> [p] in List.for_all (fun r -> List.for_all (fun x -> match X.term_extract x with | Some t, _ -> Combine.Uf.mem uf t | _ -> true )(X.leaves r) )l let try_it t facts ~for_model = Options.exec_thread_yield (); Debug.begin_case_split t.choices; let r = try if t.choices == [] then look_for_sat [] t t.gamma [] for_model else try let env, ch = CC_X.assume_literals t.gamma_finite [] facts in look_for_sat ch t env [] for_model with Exception.Inconsistent (dep, classes) -> Options.tool_req 3 "TR-CCX-CS-Case-Split-Erase-Choices"; (* we replay the conflict in look_for_sat, so we can safely ignore the explanation which is not useful *) let uf = CC_X.get_union_find t.gamma in let filt_choices = List.filter (filter_choice uf) t.choices in Debug.split_sat_contradicts_cs filt_choices; look_for_sat ~bad_last:(Yes (dep, classes)) [] { t with choices = []} t.gamma filt_choices ~for_model with Exception.Inconsistent (d, cl) -> Debug.end_case_split t.choices; Options.tool_req 3 "TR-CCX-CS-Conflict"; raise (Exception.Inconsistent (d, cl)) in Debug.end_case_split (fst r).choices; r let extract_from_semvalues acc l = List.fold_left (fun acc r -> match X.term_extract r with | Some t, _ -> SetT.add t acc | _ -> acc) acc l let extract_terms_from_choices = List.fold_left (fun acc (a, _, _, _) -> match a with | A.Eq(r1, r2) -> extract_from_semvalues acc [r1; r2] | A.Distinct (_, l) -> extract_from_semvalues acc l | A.Pred(p, _) -> extract_from_semvalues acc [p] | _ -> acc ) let extract_terms_from_assumed = List.fold_left (fun acc (a, _, _) -> match a with | LTerm r -> begin match Literal.LT.view r with | Literal.Eq (t1, t2) -> SetT.add t1 (SetT.add t2 acc) | Literal.Distinct (_, l) | Literal.Builtin (_, _, l) -> List.fold_right SetT.add l acc | Literal.Pred (t1, _) -> SetT.add t1 acc end | _ -> acc) let rec is_ordered_list l = match l with | [] | [[_]] -> true | []::r -> is_ordered_list r | [e]::r1::r2 -> is_ordered_list ((e::r1)::r2) | (e1::e2::l)::r -> let _, d1, p1 = e1 in let _, d2, p2 = e2 in (d1 > d2 || d1 = d2 && p1 > p2) && is_ordered_list ((e2::l)::r) let do_case_split t = let in_facts_l = t.cs_pending_facts in let t = {t with cs_pending_facts = []} in let facts = CC_X.empty_facts () in List.iter (List.iter (fun (a,ex,dlvl,plvl) -> CC_X.add_fact facts (LTerm a, ex, Sig.Other)) ) in_facts_l; let t, ch = try_it t facts ~for_model:false in let choices = extract_terms_from_choices SetT.empty t.choices in let choices_terms = extract_terms_from_assumed choices ch in {t with terms = Term.Set.union t.terms choices_terms}, choices_terms (* facts are sorted in decreasing order with respect to (dlvl, plvl) *) let assume ordered in_facts t = let facts = CC_X.empty_facts () in let assumed, cpt = List.fold_left (fun (assumed, cpt) ((a, ex, dlvl, plvl)) -> CC_X.add_fact facts (LTerm a, ex, Sig.Other); (a, dlvl, plvl) :: assumed, cpt+1 )([], 0) in_facts in let t = {t with assumed = assumed :: t.assumed; cs_pending_facts = in_facts :: t.cs_pending_facts} in if Options.profiling() then Profiling.assume cpt; Debug.assumed t.assumed; assert (not ordered || is_ordered_list t.assumed); let gamma, ch = CC_X.assume_literals t.gamma [] facts in let new_terms = CC_X.new_terms gamma in {t with gamma = gamma; terms = Term.Set.union t.terms new_terms}, new_terms, cpt let class_of t term = CC_X.class_of t.gamma term let query = let add_and_process_conseqs a t = (* !!! query does not modify gamma_finite anymore *) Options.exec_thread_yield (); let gamma, facts = CC_X.add t.gamma (CC_X.empty_facts()) a Ex.empty in let gamma, _ = CC_X.assume_literals gamma [] facts in { t with gamma = gamma } in fun a t -> if Options.profiling() then Profiling.query(); Options.exec_thread_yield (); Debug.query a; try match A.LT.view a with | A.Eq (t1, t2) -> let t = add_and_process_conseqs a t in CC_X.are_equal t.gamma t1 t2 ~added_terms:true | A.Distinct (false, [t1; t2]) -> let na = A.LT.neg a in let t = add_and_process_conseqs na t in (* na ? *) CC_X.are_distinct t.gamma t1 t2 | A.Distinct _ -> assert false (* devrait etre capture par une analyse statique *) | A.Pred (t1,b) -> let t = add_and_process_conseqs a t in if b then CC_X.are_distinct t.gamma t1 (Term.top()) else CC_X.are_equal t.gamma t1 (Term.top()) ~added_terms:true | _ -> let na = A.LT.neg a in let t = add_and_process_conseqs na t in CC_X.query t.gamma na with Exception.Inconsistent (d, classes) -> Yes (d, classes) let are_equal t t1 t2 add_terms = if add_terms then let facts = CC_X.empty_facts() in let gamma, facts = CC_X.add_term t.gamma facts t1 Ex.empty in let gamma, facts = CC_X.add_term gamma facts t2 Ex.empty in try let gamma, _ = CC_X.assume_literals gamma [] facts in CC_X.are_equal gamma t1 t2 ~added_terms:true with Inconsistent (ex,cl) -> Yes(ex, cl) else CC_X.are_equal t.gamma t1 t2 ~added_terms:false let add_term_in_gm gm t = let facts = CC_X.empty_facts() in let gm, facts = CC_X.add_term gm facts t Ex.empty in fst (CC_X.assume_literals gm [] facts) (* may raise Inconsistent *) let add_term env t ~add_in_cs = let gm = add_term_in_gm env.gamma t in if not add_in_cs then {env with gamma = gm} else {env with gamma=gm; gamma_finite=add_term_in_gm env.gamma_finite t} let empty () = let env = CC_X.empty () in let env, _ = CC_X.add_term env (CC_X.empty_facts()) T.vrai Ex.empty in let env, _ = CC_X.add_term env (CC_X.empty_facts()) T.faux Ex.empty in let t = { gamma = env; gamma_finite = env; choices = []; assumed = []; cs_pending_facts = []; terms = Term.Set.empty } in let a = A.LT.mk_distinct false [T.vrai; T.faux] in let t, _, _ = assume true [a, Ex.empty, 0, -1] t in t let print_model fmt t = CC_X.print_model fmt t.gamma_finite let cl_extract env = CC_X.cl_extract env.gamma let term_repr env t = CC_X.term_repr env.gamma t let assume ?(ordered=true) facts t = if Options.timers() then try Options.exec_timer_start Timers.M_CC Timers.F_assume; let res = assume ordered facts t in Options.exec_timer_pause Timers.M_CC Timers.F_assume; res with e -> Options.exec_timer_pause Timers.M_CC Timers.F_assume; raise e else assume ordered facts t let query a t = if Options.timers() then try Options.exec_timer_start Timers.M_CC Timers.F_query; let res = query a t in Options.exec_timer_pause Timers.M_CC Timers.F_query; res with e -> Options.exec_timer_pause Timers.M_CC Timers.F_query; raise e else query a t let extract_ground_terms env = env.terms let get_real_env t = t.gamma let get_case_split_env t = t.gamma_finite let are_equal env t1 t2 ~add_terms = if Options.timers() then try Options.exec_timer_start Timers.M_CC Timers.F_are_equal; let res = are_equal env t1 t2 add_terms in Options.exec_timer_pause Timers.M_CC Timers.F_are_equal; res with e -> Options.exec_timer_pause Timers.M_CC Timers.F_are_equal; raise e else are_equal env t1 t2 add_terms let compute_concrete_model env = fst (try_it env (CC_X.empty_facts ()) ~for_model:true) end module Main_Empty : S = struct type t = int let empty () = -1 let assume ?(ordered=true) _ _ = 0, T.Set.empty, 0 let query a t = No let class_of env t = [t] let are_equal env t1 t2 ~add_terms = if T.equal t1 t2 then Yes(Ex.empty, []) else No let print_model _ _ = () let cl_extract _ = [] let term_repr _ t = t let extract_ground_terms _ = Term.Set.empty let empty_ccx = CC_X.empty () let get_real_env _ = empty_ccx let get_case_split_env _ = empty_ccx let do_case_split _ = 0, T.Set.empty let add_term env t ~add_in_cs = env let compute_concrete_model e = e let terms_in_repr e = Term.Set.empty end module Main = (val ( if Options.no_theory() then (module Main_Empty : S) else (module Main_Default : S) ) : S ) alt-ergo-1.30/src/theories/records.mli0000644000175000001440000000362413014515065016275 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-1.30/src/theories/sig.mli0000644000175000001440000001341113014515065015411 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type answer = Yes of Explanation.t * Term.Set.t list | No type 'a ac = {h: Symbols.t ; t: Ty.t ; l: ('a * int) list; distribute: bool} type 'a literal = LTerm of Literal.LT.t | LSem of 'a Literal.view type theory = | Th_arith | Th_sum | Th_arrays | Th_UF type lit_origin = | Subst | CS of theory * Numbers.Q.t | NCS of theory * Numbers.Q.t | Other type 'a input = 'a Literal.view * Literal.LT.t option * Explanation.t * lit_origin type 'a fact = 'a literal * Explanation.t * lit_origin type 'a facts = { equas : 'a fact Queue.t; diseqs : 'a fact Queue.t; ineqs : 'a fact Queue.t; mutable touched : 'a Util.MI.t; } type 'a result = { assume : 'a fact list; remove: Literal.LT.t list; } type 'a solve_pb = { sbt : ('a * 'a) list; eqs : ('a * 'a) list } module type RELATION = sig type t type r type uf val empty : Term.Set.t list -> t val assume : t -> uf -> (r input) list -> t * r result val query : t -> uf -> r input -> answer val case_split : t -> uf -> for_model:bool -> (r Literal.view * bool * lit_origin) list (** case_split env returns a list of equalities *) val add : t -> uf -> r -> Term.t -> t (** add a representant to take into account *) val print_model : Format.formatter -> t -> (Term.t * r) list -> unit val new_terms : t -> Term.Set.t end module type SHOSTAK = sig (**Type of terms of the theory*) type t (**Type of representants of terms of the theory*) type r (** Name of the theory*) val name : string (** return true if the symbol is owned by the theory*) val is_mine_symb : Symbols.t -> bool (** Give a representant of a term of the theory*) val make : Term.t -> r * Literal.LT.t list val term_extract : r -> Term.t option * bool (* original term ? *) val color : (r ac) -> r val type_info : t -> Ty.t val embed : r -> t val is_mine : t -> r (** Give the leaves of a term of the theory *) val leaves : t -> r list val subst : r -> r -> t -> r val compare : r -> r -> int (* tests if two values are equal (using tags) *) val equal : t -> t -> bool val hash : t -> int (** solve r1 r2, solve the equality r1=r2 and return the substitution *) val solve : r -> r -> r solve_pb -> r solve_pb val print : Format.formatter -> t -> unit val fully_interpreted : Symbols.t -> bool val abstract_selectors : t -> (r * r) list -> r * (r * r) list (* the returned bool is true when the returned term in a constant of the theory. Otherwise, the term contains aliens that should be assigned (eg. records). In this case, it's a unit fact, not a decision *) val assign_value : r -> r list -> (Term.t * r) list -> (Term.t * bool) option (* choose the value to print and how to print it for the given term. The second term is its representative. The list is its equivalence class *) val choose_adequate_model : Term.t -> r -> (Term.t * r) list -> r * string end module type X = sig type r val make : Term.t -> r * Literal.LT.t list val type_info : r -> Ty.t val str_cmp : r -> r -> int val hash_cmp : r -> r -> int val equal : r -> r -> bool val hash : r -> int val leaves : r -> r list val subst : r -> r -> r -> r val solve : r -> r -> (r * r) list val term_embed : Term.t -> r val term_extract : r -> Term.t option * bool (* original term ? *) val ac_embed : r ac -> r val ac_extract : r -> (r ac) option val color : (r ac) -> r val fully_interpreted : Symbols.t -> bool val is_a_leaf : r -> bool val print : Format.formatter -> r -> unit val abstract_selectors : r -> (r * r) list -> r * (r * r) list val top : unit -> r val bot : unit -> r val is_solvable_theory_symbol : Symbols.t -> bool (* the returned bool is true when the returned term in a constant of the theory. Otherwise, the term contains aliens that should be assigned (eg. records). In this case, it's a unit fact, not a decision *) val assign_value : r -> r list -> (Term.t * r) list -> (Term.t * bool) option (* choose the value to print and how to print it for the given term. The second term is its representative. The list is its equivalence class *) val choose_adequate_model : Term.t -> r -> (Term.t * r) list -> r * string end alt-ergo-1.30/src/theories/uf.mli0000644000175000001440000000522513014515065015245 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module type S = sig type t type r val empty : unit -> t val add : t -> Term.t -> t * Literal.LT.t list val mem : t -> Term.t -> bool val find : t -> Term.t -> r * Explanation.t val find_r : t -> r -> r * Explanation.t val union : t -> r -> r -> Explanation.t -> t * (r * (r * r * Explanation.t) list * r) list val distinct : t -> r list -> Explanation.t -> t val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val already_distinct : t -> r list -> bool val class_of : t -> Term.t -> Term.t list val cl_extract : t -> Term.Set.t list val model : t -> (r * Term.t list * (Term.t * r) list) list * (Term.t list) list val print : Format.formatter -> t -> unit val term_repr : t -> Term.t -> Term.t val make : t -> Term.t -> r (* may raise Not_found *) val is_normalized : t -> r -> bool val assign_next : t -> (r Literal.view * bool * Sig.lit_origin) list * t val output_concrete_model : t -> unit end module Make (X : Sig.X) : S with type r = X.r alt-ergo-1.30/src/theories/arith.mli0000644000175000001440000000367713014515065015753 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module Type (X : Sig.X ): Polynome.T with type r = X.r module Shostak (X : Sig.X) (P : Polynome.EXTENDED_Polynome with type r = X.r) : Sig.SHOSTAK with type r = X.r and type t = P.t module Relation (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-1.30/src/theories/ccx.mli0000644000175000001440000000534113014515065015407 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig open Exception module type S = sig type t type r = Combine.Shostak.r val empty : unit -> t val empty_facts : unit -> r Sig.facts val add_fact : r Sig.facts -> r fact -> unit val add_term : t -> r Sig.facts -> (* acc *) Term.t -> Explanation.t -> t * r Sig.facts val add : t -> r Sig.facts -> (* acc *) Literal.LT.t -> Explanation.t -> t * r Sig.facts val assume_literals : t -> (r Sig.literal * Explanation.t * Sig.lit_origin) list -> r Sig.facts -> t * (r Sig.literal * Explanation.t * Sig.lit_origin) list val case_split : t -> for_model:bool -> (r Literal.view * bool * Sig.lit_origin) list * t val query : t -> Literal.LT.t -> Sig.answer val new_terms : t -> Term.Set.t val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val print_model : Format.formatter -> t -> unit val get_union_find : t -> Combine.Uf.t end module Main : S alt-ergo-1.30/src/theories/combine.ml0000644000175000001440000005637313014515065016110 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig (*** Combination module of Shostak theories ***) module rec CX : sig include Sig.X val extract1 : r -> X1.t option val embed1 : X1.t -> r val extract2 : r -> X2.t option val embed2 : X2.t -> r val extract3 : r -> X3.t option val embed3 : X3.t -> r val extract4 : r -> X4.t option val embed4 : X4.t -> r val extract5 : r -> X5.t option val embed5 : X5.t -> r end = struct type rview = | Term of Term.t | Ac of AC.t | X1 of X1.t | X2 of X2.t | X3 of X3.t | X4 of X4.t | X5 of X5.t type r = {v : rview ; id : int} (* begin: Hashconsing modules and functions *) module View = struct type t = r let tag tag r = { r with id=tag } let hash r = match r.v with | X1 x -> 1 + 8 * X1.hash x | X2 x -> 2 + 8 * X2.hash x | X3 x -> 3 + 8 * X3.hash x | X4 x -> 4 + 8 * X4.hash x | X5 x -> 5 + 8 * X5.hash x | Ac ac -> 7 + 8 * AC.hash ac | Term t -> 6 + 8 * Term.hash t let equal r1 r2 = match r1.v, r2.v with | X1 x, X1 y -> X1.equal x y | X2 x, X2 y -> X2.equal x y | X3 x, X3 y -> X3.equal x y | X4 x, X4 y -> X4.equal x y | X5 x, X5 y -> X5.equal x y | Term x , Term y -> Term.equal x y | Ac x , Ac y -> AC.equal x y | _ -> false end module HC = Hashcons.Make(View) let hcons v = HC.hashcons v (* end: Hashconsing modules and functions *) let embed1 x = hcons {v = X1 x; id = -1000 (* dummy *)} let embed2 x = hcons {v = X2 x; id = -1000 (* dummy *)} let embed3 x = hcons {v = X3 x; id = -1000 (* dummy *)} let embed4 x = hcons {v = X4 x; id = -1000 (* dummy *)} let embed5 x = hcons {v = X5 x; id = -1000 (* dummy *)} let ac_embed ({Sig.l = l} as t) = match l with | [] -> assert false | [x, 1] -> x | l -> let sort = List.fast_sort (fun (x,n) (y,m) -> CX.str_cmp x y) in let ac = { t with Sig.l = List.rev (sort l) } in hcons {v = Ac ac; id = -1000 (* dummy *)} let term_embed t = hcons {v = Term t; id = -1000 (* dummy *)} let extract1 = function {v=X1 r} -> Some r | _ -> None let extract2 = function {v=X2 r} -> Some r | _ -> None let extract3 = function {v=X3 r} -> Some r | _ -> None let extract4 = function {v=X4 r} -> Some r | _ -> None let extract5 = function {v=X5 r} -> Some r | _ -> None let ac_extract = function | {v = Ac t} -> Some t | _ -> None let term_extract r = match r.v with | X1 _ -> X1.term_extract r | X2 _ -> X2.term_extract r | X3 _ -> X3.term_extract r | X4 _ -> X4.term_extract r | X5 _ -> X5.term_extract r | Ac _ -> None, false (* SYLVAIN : TODO *) | Term t -> Some t, true let top () = term_embed Term.vrai let bot () = term_embed Term.faux let is_an_eq a = match Literal.LT.view a with Literal.Builtin _ -> false | _ -> true let is_int v = let ty = match v with | X1 x -> X1.type_info x | X2 x -> X2.type_info x | X3 x -> X3.type_info x | X4 x -> X4.type_info x | X5 x -> X5.type_info x | Term t -> (Term.view t).Term.ty | Ac x -> AC.type_info x in ty == Ty.Tint let type_info = function | {v=X1 t} -> X1.type_info t | {v=X2 t} -> X2.type_info t | {v=X3 t} -> X3.type_info t | {v=X4 t} -> X4.type_info t | {v=X5 t} -> X5.type_info t | {v=Ac x} -> AC.type_info x | {v=Term t} -> let {Term.ty = ty} = Term.view t in ty (* Xi < Term < Ac *) let theory_num x = match x with | Ac _ -> -1 | Term _ -> -2 | X1 _ -> -3 | X2 _ -> -4 | X3 _ -> -5 | X4 _ -> -6 | X5 _ -> -7 let compare_tag a b = theory_num a - theory_num b let str_cmp a b = if CX.equal a b then 0 else match a.v, b.v with | X1 x, X1 y -> X1.compare a b | X2 x, X2 y -> X2.compare a b | X3 x, X3 y -> X3.compare a b | X4 x, X4 y -> X4.compare a b | X5 x, X5 y -> X5.compare a b | Term x , Term y -> Term.compare x y | Ac x , Ac y -> AC.compare x y | va, vb -> compare_tag va vb (*** implementations before hash-consing semantic values let equal a b = CX.compare a b = 0 let hash r = match r.v with | Term t -> Term.hash t | Ac x -> AC.hash x | X1 x -> X1.hash x | X2 x -> X2.hash x | X3 x -> X3.hash x | X4 x -> X4.hash x | X5 x -> X5.hash x ***) let equal a b = a.id = b.id let hash v = v.id let hash_cmp a b = a.id - b.id (* should be called hash_cmp and used where structural_compare is not needed let compare a b = let c = Pervasives.compare a.id b.id in let c' = Pervasives.compare b.id a.id in assert ((c = 0 && c' = 0) || (c*c' < 0)); c *) module SX = Set.Make(struct type t = r let compare = CX.hash_cmp end) let leaves r = match r.v with | X1 t -> X1.leaves t | X2 t -> X2.leaves t | X3 t -> X3.leaves t | X4 t -> X4.leaves t | X5 t -> X5.leaves t | Ac t -> r :: (AC.leaves t) | Term _ -> [r] let subst p v r = if equal p v then r else match r.v with | X1 t -> X1.subst p v t | X2 t -> X2.subst p v t | X3 t -> X3.subst p v t | X4 t -> X4.subst p v t | X5 t -> X5.subst p v t | Ac t -> if equal p r then v else AC.subst p v t | Term _ -> if equal p r then v else r let make t = let {Term.f=sb} = Term.view t in match X1.is_mine_symb sb, not (restricted ()) && X2.is_mine_symb sb, not (restricted ()) && X3.is_mine_symb sb, not (restricted ()) && X4.is_mine_symb sb, not (restricted ()) && X5.is_mine_symb sb, AC.is_mine_symb sb with | true , false , false, false, false, false -> X1.make t | false , true , false, false, false, false -> X2.make t | false , false , true , false, false, false -> X3.make t | false , false , false, true , false, false -> X4.make t | false , false , false, false, true , false -> X5.make t | false , false , false, false, false, true -> AC.make t | false , false , false, false, false, false -> term_embed t, [] | _ -> assert false let fully_interpreted sb = match X1.is_mine_symb sb, not (restricted ()) && X2.is_mine_symb sb, not (restricted ()) && X3.is_mine_symb sb, not (restricted ()) && X4.is_mine_symb sb, not (restricted ()) && X5.is_mine_symb sb, AC.is_mine_symb sb with | true , false , false, false, false, false -> X1.fully_interpreted sb | false , true , false, false, false, false -> X2.fully_interpreted sb | false , false , true , false, false, false -> X3.fully_interpreted sb | false , false , false, true , false, false -> X4.fully_interpreted sb | false , false , false, false, true , false -> X5.fully_interpreted sb | false , false , false, false, false, true -> AC.fully_interpreted sb | false , false , false, false, false, false -> false | _ -> assert false let is_solvable_theory_symbol sb = X1.is_mine_symb sb || not (restricted ()) && ((*X2.is_mine_symb sb || print records*) X3.is_mine_symb sb || X4.is_mine_symb sb || X5.is_mine_symb sb)(* || AC.is_mine_symb sb*) let is_a_leaf r = match r.v with | Term _ | Ac _ -> true | _ -> false let color ac = match ac.Sig.l with | [] -> assert false | [r,1] -> r | _ -> match X1.is_mine_symb ac.Sig.h, X2.is_mine_symb ac.Sig.h, X3.is_mine_symb ac.Sig.h, X4.is_mine_symb ac.Sig.h, X5.is_mine_symb ac.Sig.h, AC.is_mine_symb ac.Sig.h with | true , false , false, false, false, false -> X1.color ac | false , true , false, false, false, false -> X2.color ac | false , false , true , false, false, false -> X3.color ac | false , false , false, true , false, false -> X4.color ac | false , false , false, false, true, false -> X5.color ac | false , false , false, false, false, true -> ac_embed ac | _ -> assert false (*BISECT-IGNORE-BEGIN*) module Debug = struct let print fmt r = if term_like_pp () then match r.v with | X1 t -> fprintf fmt "%a" X1.print t | X2 t -> fprintf fmt "%a" X2.print t | X3 t -> fprintf fmt "%a" X3.print t | X4 t -> fprintf fmt "%a" X4.print t | X5 t -> fprintf fmt "%a" X5.print t | Term t -> fprintf fmt "%a" Term.print t | Ac t -> fprintf fmt "%a" AC.print t else match r.v with | X1 t -> fprintf fmt "X1(%s):[%a]" X1.name X1.print t | X2 t -> fprintf fmt "X2(%s):[%a]" X2.name X2.print t | X3 t -> fprintf fmt "X3(%s):[%a]" X3.name X3.print t | X4 t -> fprintf fmt "X3(%s):[%a]" X4.name X4.print t | X5 t -> fprintf fmt "X3(%s):[%a]" X5.name X5.print t | Term t -> fprintf fmt "FT:[%a]" Term.print t | Ac t -> fprintf fmt "Ac:[%a]" AC.print t let print_sbt msg sbs = if debug_combine () then begin let c = ref 0 in fprintf fmt "%s subst:@." msg; List.iter (fun (p,v) -> incr c; fprintf fmt " %d) %a |-> %a@." !c print p print v) sbs; fprintf fmt "@." end let debug_abstraction_result oa ob a b acc = if debug_combine () then begin fprintf fmt "@.== debug_abstraction_result ==@."; fprintf fmt "@.Initial equaliy: %a = %a@." CX.print oa CX.print ob; fprintf fmt "abstracted equality: %a = %a@." CX.print a CX.print b; fprintf fmt "selectors elimination result:@."; let cpt = ref 0 in List.iter (fun (p,v) -> incr cpt; fprintf fmt "\t(%d) %a |-> %a@." !cpt CX.print p CX.print v )acc; fprintf fmt "@." end let solve_one a b = if debug_combine () then fprintf fmt "solve one %a = %a@." CX.print a CX.print b let debug_abstract_selectors a = if debug_combine () then fprintf fmt "abstract selectors of %a@." CX.print a let assert_have_mem_types tya tyb = assert ( not (Options.enable_assertions()) || if not (Ty.compare tya tyb = 0) then ( fprintf fmt "@.Tya = %a and @.Tyb = %a@.@." Ty.print tya Ty.print tyb; false) else true) let solve a b = if debug_combine () then fprintf fmt "@.[combine] I solve %a = %a:@." print a print b end (*BISECT-IGNORE-END*) let print = Debug.print let abstract_selectors a acc = Debug.debug_abstract_selectors a; match a.v with | X1 a -> X1.abstract_selectors a acc | X2 a -> X2.abstract_selectors a acc | X3 a -> X3.abstract_selectors a acc | X4 a -> X4.abstract_selectors a acc | X5 a -> X5.abstract_selectors a acc | Term _ -> a, acc | Ac a -> AC.abstract_selectors a acc let abstract_equality a b = let aux r acc = match r.v with | Ac ({l=args} as ac) -> let args, acc = List.fold_left (fun (args, acc) (r, i) -> let r, acc = abstract_selectors r acc in (r, i) :: args, acc )([],acc) args in ac_embed {ac with l = AC.compact args}, acc | _ -> abstract_selectors r acc in let a', acc = aux a [] in let b', acc = aux b acc in a', b', acc let apply_subst r l = List.fold_left (fun r (p,v) -> CX.subst p v r) r l let triangular_down sbs = List.fold_right (fun (p,v) nsbs -> (p, apply_subst v nsbs) :: nsbs) sbs [] let make_idemp a b sbs = Debug.print_sbt "Non triangular" sbs; let sbs = triangular_down sbs in let sbs = triangular_down (List.rev sbs) in (* triangular up *) let original = List.fold_right SX.add (CX.leaves a) SX.empty in let original = List.fold_right SX.add (CX.leaves b) original in let sbs = List.filter (fun (p,v) -> match p.v with | Ac _ -> true | Term _ -> SX.mem p original | _ -> assert false )sbs in Debug.print_sbt "Triangular and cleaned" sbs; assert (not (Options.enable_assertions()) || equal (apply_subst a sbs) (apply_subst b sbs)); sbs let apply_subst_right r sbt = List.fold_right (fun (p,v)r -> CX.subst p v r) sbt r let merge_sbt sbt1 sbt2 = sbt1 @ sbt2 let solve_uninterpreted r1 r2 pb = (* r1 != r2*) if CX.str_cmp r1 r2 > 0 then { pb with sbt = (r1,r2)::pb.sbt } else { pb with sbt = (r2,r1)::pb.sbt } let rec solve_list pb = match pb.eqs with | [] -> Debug.print_sbt "Should be triangular and cleaned" pb.sbt; pb.sbt | (a,b) :: eqs -> let pb = {pb with eqs=eqs} in Debug.solve_one a b; let ra = apply_subst_right a pb.sbt in let rb = apply_subst_right b pb.sbt in if CX.equal ra rb then solve_list pb else let tya = CX.type_info ra in let tyb = CX.type_info rb in Debug.assert_have_mem_types tya tyb; let pb = match tya with | Ty.Tint | Ty.Treal -> X1.solve ra rb pb | Ty.Trecord _ -> X2.solve ra rb pb | Ty.Tbitv _ -> X3.solve ra rb pb | Ty.Tsum _ -> X5.solve ra rb pb | _ -> solve_uninterpreted ra rb pb in solve_list pb let solve_abstracted oa ob a b sbt = Debug.debug_abstraction_result oa ob a b sbt; let ra = apply_subst_right a sbt in let rb = apply_subst_right b sbt in let sbt' = solve_list { sbt=[] ; eqs=[ra,rb] } in match sbt', sbt with | [], _::_ -> [] (* the original equality was trivial *) | _ -> make_idemp oa ob (List.rev_append sbt sbt') let solve a b = let a', b', acc = abstract_equality a b in solve_abstracted a b a' b' acc let assign_value r distincts eq = let opt = match r.v, type_info r with | _, Ty.Tint | _, Ty.Treal -> X1.assign_value r distincts eq | _, Ty.Trecord _ -> X2.assign_value r distincts eq | _, Ty.Tbitv _ -> X3.assign_value r distincts eq | _, Ty.Tfarray _ -> X4.assign_value r distincts eq | _, Ty.Tsum _ -> X5.assign_value r distincts eq | Term t, ty -> if (Term.view t).Term.depth = 1 || List.exists (fun (t,_) -> (Term.view t).Term.depth = 1) eq then None else Some (Term.fresh_name ty, false) (* false <-> not a case-split *) | _ -> assert false in if debug_interpretation() then begin fprintf fmt "[combine] assign value to representative %a : " print r; match opt with | None -> fprintf fmt "None@." | Some(res, is_cs) -> fprintf fmt " %a@." Term.print res end; opt let choose_adequate_model t rep l = let r, pprint = match Term.type_info t with | Ty.Tint | Ty.Treal -> X1.choose_adequate_model t rep l | Ty.Tbitv _ -> X3.choose_adequate_model t rep l | Ty.Tsum _ -> X5.choose_adequate_model t rep l | Ty.Trecord _ -> X2.choose_adequate_model t rep l | Ty.Tfarray _ -> X4.choose_adequate_model t rep l | _ -> let acc = List.fold_left (fun acc (s, r) -> if (Term.view s).Term.depth <= 1 then match acc with | Some(s', r') when Term.compare s' s > 0 -> acc | _ -> Some (s, r) else acc ) None l in let r = match acc with | Some (_,r) -> r | None -> match term_extract rep with | Some t, true when (Term.view t).Term.depth = 1 -> rep | _ -> if debug_interpretation() then begin fprintf fmt "[Combine.choose_adequate_model] "; fprintf fmt "What to choose for term %a with rep %a ??@." Term.print t print rep; List.iter (fun (t, r) -> fprintf fmt " > impossible case: %a -- %a@." Term.print t print r )l; end; assert false in ignore (flush_str_formatter ()); fprintf str_formatter "%a" print r; (* it's a EUF constant *) r, flush_str_formatter () in if debug_interpretation() then fprintf fmt "[combine] %a selected as a model for %a@." print r Term.print t; r, pprint end and TX1 : Polynome.T with type r = CX.r = Arith.Type(CX) and X1 : Sig.SHOSTAK with type t = TX1.t and type r = CX.r = Arith.Shostak (CX) (struct include TX1 let extract = CX.extract1 let embed = CX.embed1 end) and X2 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Records.abstract = Records.Shostak (struct include CX let extract = extract2 let embed = embed2 end) and X3 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Bitv.abstract = Bitv.Shostak (struct include CX let extract = extract3 let embed = embed3 end) and X4 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Arrays.abstract = Arrays.Shostak (struct include CX let extract = extract4 let embed = embed4 end) and X5 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Sum.abstract = Sum.Shostak (struct include CX let extract = extract5 let embed = embed5 end) (* Its signature is not Sig.SHOSTAK because it does not provide a solver *) and AC : Ac.S with type r = CX.r = Ac.Make(CX) (*** Instantiation of Uf.Make and Use.Make with CX ***) module Uf : Uf.S with type r = CX.r = Uf.Make(CX) module Use = Use.Make(CX) (*** Combination module of Relations ***) module Rel1 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Arith.Relation (CX)(Uf) (struct include TX1 let extract = CX.extract1 let embed = CX.embed1 end) module Rel2 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Records.Relation (struct include CX let extract = extract2 let embed = embed2 end)(Uf) module Rel3 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Bitv.Relation (struct include CX let extract = extract3 let embed = embed3 end)(Uf) module Rel4 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Arrays.Relation (struct include CX let extract = extract4 let embed = embed4 end)(Uf) module Rel5 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Sum.Relation (struct include CX let extract = extract5 let embed = embed5 end)(Uf) module Relation : Sig.RELATION with type r = CX.r and type uf = Uf.t = struct type r = CX.r type uf = Uf.t type t = { r1: Rel1.t; r2: Rel2.t; r3: Rel3.t; r4: Rel4.t; r5: Rel5.t; } let empty classes = { r1=Rel1.empty classes; r2=Rel2.empty classes; r3=Rel3.empty classes; r4=Rel4.empty classes; r5=Rel5.empty classes; } let (|@|) l1 l2 = if l1 == [] then l2 else if l2 == [] then l1 else List.rev_append l1 l2 let assume env uf sa = Options.exec_thread_yield (); let env1, { assume = a1; remove = rm1} = Rel1.assume env.r1 uf sa in let env2, { assume = a2; remove = rm2} = Rel2.assume env.r2 uf sa in let env3, { assume = a3; remove = rm3} = Rel3.assume env.r3 uf sa in let env4, { assume = a4; remove = rm4} = Rel4.assume env.r4 uf sa in let env5, { assume = a5; remove = rm5} = Rel5.assume env.r5 uf sa in {r1=env1; r2=env2; r3=env3; r4=env4; r5=env5}, { assume = a1 |@| a2 |@| a3 |@| a4 |@| a5; remove = rm1 |@| rm2 |@| rm3 |@| rm4 |@| rm5;} let query env uf a = Options.exec_thread_yield (); match Rel1.query env.r1 uf a with | Yes _ as ans -> ans | No -> match Rel2.query env.r2 uf a with | Yes _ as ans -> ans | No -> match Rel3.query env.r3 uf a with | Yes _ as ans -> ans | No -> match Rel4.query env.r4 uf a with | Yes _ as ans -> ans | No -> Rel5.query env.r5 uf a let case_split env uf ~for_model = Options.exec_thread_yield (); let seq1 = Rel1.case_split env.r1 uf for_model in let seq2 = Rel2.case_split env.r2 uf for_model in let seq3 = Rel3.case_split env.r3 uf for_model in let seq4 = Rel4.case_split env.r4 uf for_model in let seq5 = Rel5.case_split env.r5 uf for_model in let l = seq1 |@| seq2 |@| seq3 |@| seq4 |@| seq5 in List.sort (fun (_,_,sz1) (_,_,sz2) -> match sz1, sz2 with | CS(_,sz1), CS(_,sz2) -> Numbers.Q.compare sz1 sz2 | _ -> assert false )l let add env uf r t = Options.exec_thread_yield (); {r1=Rel1.add env.r1 uf r t; r2=Rel2.add env.r2 uf r t; r3=Rel3.add env.r3 uf r t; r4=Rel4.add env.r4 uf r t; r5=Rel5.add env.r5 uf r t; } let print_model fmt env rs = Rel1.print_model fmt env.r1 rs; Rel2.print_model fmt env.r2 rs; Rel3.print_model fmt env.r3 rs; Rel4.print_model fmt env.r4 rs; Rel5.print_model fmt env.r5 rs let new_terms env = let t1 = Rel1.new_terms env.r1 in let t2 = Rel2.new_terms env.r2 in let t3 = Rel3.new_terms env.r3 in let t4 = Rel4.new_terms env.r4 in let t5 = Rel5.new_terms env.r5 in Term.Set.union t1 (Term.Set.union t2 (Term.Set.union t3 (Term.Set.union t4 t5))) end module Shostak = CX alt-ergo-1.30/src/theories/records.ml0000644000175000001440000003216113014515065016122 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig module Hs = Hstring module T = Term type ('a, 'b) mine = Yes of 'a | No of 'b type 'a abstract = | Record of (Hs.t * 'a abstract) list * Ty.t | Access of Hs.t * 'a abstract * Ty.t | Other of 'a * Ty.t module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) = struct module XS = Set.Make(struct type t = X.r let compare = X.hash_cmp end) let name = "records" type t = X.r abstract type r = X.r (*BISECT-IGNORE-BEGIN*) module Debug = struct let rec print fmt = function | Record (lbs, _) -> fprintf fmt "{"; let _ = List.fold_left (fun first (lb, e) -> fprintf fmt "%s%s = %a" (if first then "" else "; ") (Hs.view lb) print e; false ) true lbs in fprintf fmt "}" | Access(a, e, _) -> fprintf fmt "%a.%s" print e (Hs.view a) | Other(t, _) -> X.print fmt t end (*BISECT-IGNORE-END*) let print = Debug.print let rec raw_compare r1 r2 = match r1, r2 with | Other (u1, ty1), Other (u2, ty2) -> let c = Ty.compare ty1 ty2 in if c <> 0 then c else X.str_cmp u1 u2 | Other _, _ -> -1 | _, Other _ -> 1 | Access (s1, u1, ty1), Access (s2, u2, ty2) -> let c = Ty.compare ty1 ty2 in if c <> 0 then c else let c = Hs.compare s1 s2 in if c <> 0 then c else raw_compare u1 u2 | Access _, _ -> -1 | _, Access _ -> 1 | Record (lbs1, ty1), Record (lbs2, ty2) -> let c = Ty.compare ty1 ty2 in if c <> 0 then c else raw_compare_list lbs1 lbs2 and raw_compare_list l1 l2 = match l1, l2 with | [], [] -> 0 | [], _ -> 1 | _, [] -> -1 | (_, x1)::l1, (_, x2)::l2 -> let c = raw_compare x1 x2 in if c<>0 then c else raw_compare_list l1 l2 let rec normalize v = match v with | Record (lbs, ty) -> begin let lbs_n = List.map (fun (lb, x) -> lb, normalize x) lbs in match lbs_n with | (lb1, Access(lb2, x, _)) :: l when Hs.equal lb1 lb2 -> if List.for_all (function | (lb1, Access(lb2, y, _)) -> Hs.equal lb1 lb2 && raw_compare x y = 0 | _ -> false) l then x else Record (lbs_n, ty) | _ -> Record (lbs_n, ty) end | Access (a, x, ty) -> begin match normalize x with | Record (lbs, _) -> Hs.list_assoc a lbs | x_n -> Access (a, x_n, ty) end | Other _ -> v let embed r = match X.extract r with | Some p -> p | None -> Other(r, X.type_info r) let compare_mine t u = raw_compare (normalize t) (normalize u) let compare x y = compare_mine (embed x) (embed y) let rec equal r1 r2 = match r1, r2 with | Other (u1, ty1), Other (u2, ty2) -> Ty.equal ty1 ty2 && X.equal u1 u2 | Access (s1, u1, ty1), Access (s2, u2, ty2) -> Hs.equal s1 s2 && Ty.equal ty1 ty2 && equal u1 u2 | Record (lbs1, ty1), Record (lbs2, ty2) -> Ty.equal ty1 ty2 && equal_list lbs1 lbs2 | Other _, _ | _, Other _ | Access _, _ | _, Access _ -> false and equal_list l1 l2 = try List.for_all2 (fun (_,r1) (_,r2) -> equal r1 r2) l1 l2 with Invalid_argument _ -> false let is_mine t = match normalize t with | Other(r, _) -> r | x -> X.embed x let type_info = function | Record (_, ty) | Access (_, _, ty) | Other (_, ty) -> ty let make t = let rec make_rec t ctx = let { T.f = f; xs = xs; ty = ty} = T.view t in match f, ty with | Symbols.Op (Symbols.Record), Ty.Trecord {Ty.lbs=lbs} -> assert (List.length xs = List.length lbs); let l, ctx = List.fold_right2 (fun x (lb, _) (l, ctx) -> let r, ctx = make_rec x ctx in let tyr = type_info r in let dlb = T.make (Symbols.Op (Symbols.Access lb)) [t] tyr in let c = Literal.LT.mk_eq dlb x in (lb, r)::l, c::ctx ) xs lbs ([], ctx) in Record (l, ty), ctx | Symbols.Op (Symbols.Access a), _ -> begin match xs with | [x] -> let r, ctx = make_rec x ctx in Access (a, r, ty), ctx | _ -> assert false end | _, _ -> let r, ctx' = X.make t in Other (r, ty), ctx'@ctx in let r, ctx = make_rec t [] in let is_m = is_mine r in is_m, ctx let color _ = assert false let embed r = match X.extract r with | Some p -> p | None -> Other(r, X.type_info r) let xs_of_list = List.fold_left (fun s x -> XS.add x s) XS.empty let leaves t = let rec leaves t = match normalize t with | Record (lbs, _) -> List.fold_left (fun s (_, x) -> XS.union (leaves x) s) XS.empty lbs | Access (_, x, _) -> leaves x | Other (x, _) -> xs_of_list (X.leaves x) in XS.elements (leaves t) let rec hash = function | Record (lbs, ty) -> List.fold_left (fun h (lb, x) -> 17 * hash x + 13 * Hs.hash lb + h) (Ty.hash ty) lbs | Access (a, x, ty) -> 19 * hash x + 17 * Hs.hash a + Ty.hash ty | Other (x, ty) -> Ty.hash ty + 23 * X.hash x let rec subst_rec p v r = match r with | Other (t, ty) -> embed (if X.equal p t then v else X.subst p v t) | Access (a, t, ty) -> Access (a, subst_rec p v t, ty) | Record (lbs, ty) -> let lbs = List.map (fun (lb, t) -> lb, subst_rec p v t) lbs in Record (lbs, ty) let subst p v r = is_mine (subst_rec p v r) let is_mine_symb = function | Symbols.Op (Symbols.Record | Symbols.Access _) -> true | _ -> false let abstract_access field e ty acc = let xe = is_mine e in let abs_right_xe, acc = try List.assoc xe acc, acc with Not_found -> let left_abs_xe2, acc = X.abstract_selectors xe acc in match X.type_info left_abs_xe2 with | (Ty.Trecord { Ty.args=args; name=name; lbs=lbs }) as tyr -> let flds = List.map (fun (lb,ty) -> lb, embed (X.term_embed (T.fresh_name ty))) lbs in let record = is_mine (Record (flds, tyr)) in record, (left_abs_xe2, record) :: acc | _ -> assert false in let abs_access = normalize (Access (field, embed abs_right_xe, ty)) in is_mine abs_access, acc let abstract_selectors v acc = match v with (* Handled by combine. Should not happen! *) | Other (r, ty) -> assert false (* This is not a selector *) | Record (fields,ty) -> let flds, acc = List.fold_left (fun (flds,acc) (lbl,e) -> let e, acc = X.abstract_selectors (is_mine e) acc in (lbl, embed e)::flds, acc )([], acc) fields in is_mine (Record (List.rev flds, ty)), acc (* Selector ! Interesting case !*) | Access (field, e, ty) -> abstract_access field e ty acc (* Shostak'pair solver adapted to records *) let mk_fresh_record x info = let ty = type_info x in let lbs = match ty with Ty.Trecord r -> r.Ty.lbs | _ -> assert false in let lbs = List.map (fun (lb, ty) -> match info with | Some (a, v) when Hs.equal lb a -> lb, v | _ -> let n = embed (X.term_embed (T.fresh_name ty)) in lb, n) lbs in Record (lbs, ty), lbs let rec occurs x = function | Record (lbs, _) -> List.exists (fun (_, v) -> occurs x v) lbs | Access (_, v, _) -> occurs x v | Other _ as v -> compare_mine x v = 0 (* XXX *) let direct_args_of_labels x = List.exists (fun (_, y)-> compare_mine x y = 0) let rec subst_access x s e = match e with | Record (lbs, ty) -> Record (List.map (fun (n,e') -> n, subst_access x s e') lbs, ty) | Access (lb, e', _) when compare_mine x e' = 0 -> Hs.list_assoc lb s | Access (lb', e', ty) -> Access (lb', subst_access x s e', ty) | Other _ -> e let rec find_list x = function | [] -> raise Not_found | (y, t) :: _ when compare_mine x y = 0 -> t | _ :: l -> find_list x l let split l = let rec split_rec acc = function | [] -> acc, [] | ((x, t) as v) :: l -> try acc, (t, find_list x acc) :: l with Not_found -> split_rec (v::acc) l in split_rec [] l let fully_interpreted _ = false let rec term_extract r = match X.extract r with | Some v -> begin match v with | Record (lbs, ty) -> begin try let lbs = List.map (fun (_, r) -> match term_extract (is_mine r) with | None, _ -> raise Not_found | Some t, _ -> t) lbs in Some (T.make (Symbols.Op Symbols.Record) lbs ty), false with Not_found -> None, false end | Access (a, r, ty) -> begin match X.term_extract (is_mine r) with | None, _ -> None, false | Some t, _ -> Some (T.make (Symbols.Op (Symbols.Access a)) [t] ty), false end | Other (r, _) -> X.term_extract r end | None -> X.term_extract r let orient_solved p v pb = if List.mem p (X.leaves v) then raise Exception.Unsolvable; { pb with sbt = (p,v) :: pb.sbt } let solve r1 r2 pb = match embed r1, embed r2 with | Record (l1, _), Record (l2, _) -> let eqs = List.fold_left2 (fun eqs (a,b) (x,y) -> assert (Hs.compare a x = 0); (is_mine y, is_mine b) :: eqs )pb.eqs l1 l2 in {pb with eqs=eqs} | Other (a1,_), Other (a2,_) -> if X.str_cmp r1 r2 > 0 then { pb with sbt = (r1,r2)::pb.sbt } else { pb with sbt = (r2,r1)::pb.sbt } | Other (a1,_), Record (l2, _) -> orient_solved r1 r2 pb | Record (l1, _), Other (a2,_) -> orient_solved r2 r1 pb | Access _ , _ -> assert false | _ , Access _ -> assert false let make t = if Options.timers() then try Options.exec_timer_start Timers.M_Records Timers.F_make; let res = make t in Options.exec_timer_pause Timers.M_Records Timers.F_make; res with e -> Options.exec_timer_pause Timers.M_Records Timers.F_make; raise e else make t let solve r1 r2 pb = if Options.timers() then try Options.exec_timer_start Timers.M_Records Timers.F_solve; let res = solve r1 r2 pb in Options.exec_timer_pause Timers.M_Records Timers.F_solve; res with e -> Options.exec_timer_pause Timers.M_Records Timers.F_solve; raise e else solve r1 r2 pb let assign_value t _ eq = match embed t with | Access _ -> None | Record (_, ty) -> if List.exists (fun (t,_) -> (Term.view t).Term.depth = 1) eq then None else Some (Term.fresh_name ty, false) | Other (_,ty) -> match ty with | Ty.Trecord {Ty.args; name; lbs} -> let rev_lbs = List.rev_map (fun (hs, ty) -> Term.fresh_name ty) lbs in let s = Term.make (Symbols.Op Symbols.Record) (List.rev rev_lbs) ty in Some (s, false) (* false <-> not a case-split *) | _ -> assert false let choose_adequate_model t _ l = let acc = List.fold_left (fun acc (s, r) -> if (Term.view s).Term.depth <> 1 then acc else match acc with | Some(s', r') when Term.compare s' s > 0 -> acc | _ -> Some (s, r) ) None l in match acc with | Some (_,r) -> ignore (flush_str_formatter ()); fprintf str_formatter "%a" X.print r; (* it's a EUF constant *) r, flush_str_formatter () | _ -> assert false end module Relation (X : ALIEN) (Uf : Uf.S) = struct type r = X.r type uf = Uf.t type t = unit exception Inconsistent let empty _ = () let assume _ _ _ = (), { assume = []; remove = []} let query _ _ _ = Sig.No let case_split env _ ~for_model = [] let add env _ _ _ = env let print_model _ _ _ = () let new_terms env = T.Set.empty end alt-ergo-1.30/src/theories/ccx.ml0000644000175000001440000004766413014515065015254 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig open Exception module X = Combine.Shostak module Ex = Explanation module SetF = Formula.Set module T = Term module A = Literal module LR = A.Make(struct type t = X.r let compare = X.str_cmp include X end) module SetT = Term.Set module Sy = Symbols module type S = sig type t type r = Combine.Shostak.r val empty : unit -> t val empty_facts : unit -> r Sig.facts val add_fact : r Sig.facts -> r fact -> unit val add_term : t -> r Sig.facts -> (* acc *) Term.t -> Explanation.t -> t * r Sig.facts val add : t -> r Sig.facts -> (* acc *) Literal.LT.t -> Explanation.t -> t * r Sig.facts val assume_literals : t -> (r Sig.literal * Explanation.t * Sig.lit_origin) list -> r Sig.facts -> t * (r Sig.literal * Explanation.t * Sig.lit_origin) list val case_split : t -> for_model:bool -> (r Literal.view * bool * Sig.lit_origin) list * t val query : t -> Literal.LT.t -> Sig.answer val new_terms : t -> Term.Set.t val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val print_model : Format.formatter -> t -> unit val get_union_find : t -> Combine.Uf.t end module Main : S = struct module SetA = Use.SA module Use = Combine.Use module Uf = Combine.Uf module Rel = Combine.Relation module Q = Queue module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) type t = { use : Use.t; uf : Uf.t ; relation : Rel.t } type r = Combine.Shostak.r let empty () = { use = Use.empty ; uf = Uf.empty () ; relation = Rel.empty []; } let empty_facts () = { equas = Queue.create (); ineqs = Queue.create (); diseqs = Queue.create (); touched = Util.MI.empty } let add_fact facts ((lit, ex, orig) as e) = match lit with | LSem Literal.Pred _ | LSem Literal.Eq _ -> Queue.push e facts.equas | LSem Literal.Distinct _ -> Queue.push e facts.diseqs | LSem Literal.Builtin _ -> Queue.push e facts.ineqs | LTerm a -> match Literal.LT.view a with | Literal.Pred _ | Literal.Eq _ -> Queue.push e facts.equas | Literal.Distinct _ -> Queue.push e facts.diseqs | Literal.Builtin _ -> Queue.push e facts.ineqs (*BISECT-IGNORE-BEGIN*) module Debug = struct let facts (f : r Sig.facts) msg = let aux fmt q = Q.iter (fun (lit,_,_) -> match lit with | LSem sa -> fprintf fmt " > LSem %a@." LR.print (LR.make sa) | LTerm a -> fprintf fmt " > LTerm %a@."Literal.LT.print a )q in let aux2 fmt mp = Util.MI.iter (fun _ x -> fprintf fmt "%a |-> ... (See Uf)@." X.print x) mp in if debug_cc () then begin fprintf fmt "I am in %s with the following facts@." msg; fprintf fmt "---- Begin Facts -----------------------------------@."; fprintf fmt "Equalities:@.%a" aux f.equas; fprintf fmt "Disequalities:@.%a" aux f.diseqs; fprintf fmt "Inequalities:@.%a" aux f.ineqs; fprintf fmt "Touched:@.%a" aux2 f.touched; fprintf fmt "---- End Facts -----------------------------------@.@."; end let cc r1 r2 = if debug_cc () then fprintf fmt "[cc] congruence closure : %a = %a@." X.print r1 X.print r2 let make_cst t ctx = if debug_cc () then if ctx != [] then begin fprintf fmt "[cc] constraints of make(%a)@." Term.print t; let c = ref 0 in List.iter (fun a -> incr c; fprintf fmt " %d) %a@." !c A.LT.print a) ctx end let add_to_use t = if debug_cc () then fprintf fmt "[cc] add_to_use: %a@." T.print t let lrepr fmt = List.iter (fprintf fmt "%a " X.print) let leaves t lvs = fprintf fmt "[cc] leaves of %a@.@." T.print t; lrepr fmt lvs let contra_congruence a ex = if debug_cc () then fprintf fmt "[cc] find that %a %a by contra-congruence@." A.LT.print a Ex.print ex let assume_literal sa = if debug_cc () then fprintf fmt "[cc] assume literal : %a@." LR.print (LR.make sa) let congruent a ex = if debug_cc () then fprintf fmt "[cc] new fact by conrgruence : %a ex[%a]@." A.LT.print a Ex.print ex let cc_result p v touched = if debug_cc() then begin fprintf fmt "[cc] the binding %a -> %a touched:@." X.print p X.print v; List.iter (fun (x, y, _) -> fprintf fmt " > %a ~~ becomes ~> %a@." X.print x X.print y) touched end end (*BISECT-IGNORE-END*) let one, _ = X.make (Term.make (Sy.name "@bottom") [] Ty.Tint) let concat_leaves uf l = let rec concat_rec acc t = match X.leaves (fst (Uf.find uf t)) , acc with [] , _ -> one::acc | res, [] -> res | res , _ -> List.rev_append res acc in match List.fold_left concat_rec [] l with [] -> [one] | res -> res let are_equal env ex t1 t2 = if T.equal t1 t2 then ex else match Uf.are_equal env.uf t1 t2 ~added_terms:true with | Yes (dep, _) -> Ex.union ex dep | No -> raise Exit let equal_only_by_congruence env facts t1 t2 = if not (T.equal t1 t2) then let {T.f=f1; xs=xs1; ty=ty1} = T.view t1 in if not (X.fully_interpreted f1) then let {T.f=f2; xs=xs2; ty=ty2} = T.view t2 in if Symbols.equal f1 f2 && Ty.equal ty1 ty2 then try let ex = List.fold_left2 (are_equal env) Ex.empty xs1 xs2 in let a = A.LT.mk_eq t1 t2 in Debug.congruent a ex; Q.push (LTerm a, ex, Sig.Other) facts.equas with Exit -> () let congruents env facts t1 s = SetT.iter (equal_only_by_congruence env facts t1) s let fold_find_with_explanation find ex l = List.fold_left (fun (lr, ex) t -> let r, ex_r = find t in r::lr, Ex.union ex_r ex) ([], ex) l let view find va ex_a = match va with | A.Pred (t1, b) -> let r1, ex1 = find t1 in let ex = Ex.union ex1 ex_a in LR.mkv_pred r1 b, ex | A.Eq (t1, t2) -> let r1, ex1 = find t1 in let r2, ex2 = find t2 in let ex = Ex.union (Ex.union ex1 ex2) ex_a in LR.mkv_eq r1 r2, ex | A.Distinct (b, lt) -> let lr, ex = fold_find_with_explanation find ex_a lt in LR.mkv_distinct b (List.rev lr), ex | A.Builtin(b, s, l) -> let lr, ex = fold_find_with_explanation find ex_a l in LR.mkv_builtin b s (List.rev lr), ex let term_canonical_view env a ex_a = view (Uf.find env.uf) (A.LT.view a) ex_a let canonical_view env a ex_a = view (Uf.find_r env.uf) a ex_a (* Begin: new implementation of add, add_term, assume_literals and all that *) let new_facts_by_contra_congruence env facts r bol = match X.term_extract r with | None, _ -> () | Some _, false -> () (* not an original term *) | Some t1, true -> (* original term *) match T.view t1 with | {T.f=f1 ; xs=[x]} -> let ty_x = (Term.view x).Term.ty in List.iter (fun t2 -> match T.view t2 with | {T.f=f2 ; xs=[y]} when Sy.equal f1 f2 -> let ty_y = (Term.view y).Term.ty in if Ty.equal ty_x ty_y then begin match Uf.are_distinct env.uf t1 t2 with | Yes (ex_r, _) -> let a = A.LT.mk_distinct false [x; y] in Debug.contra_congruence a ex_r; Q.push (LTerm a, ex_r, Sig.Other) facts.diseqs | No -> assert false end | _ -> () ) (Uf.class_of env.uf bol) | _ -> () let clean_use = List.fold_left (fun env a -> match A.LT.view a with | A.Distinct (_, lt) | A.Builtin (_, _, lt) -> let lvs = concat_leaves env.uf lt in List.fold_left (fun env rx -> let st, sa = Use.find rx env.use in (* SetA does not use ex, so Ex.empty is OK for removing *) let sa = SetA.remove (a, Ex.empty) sa in { env with use = Use.add rx (st,sa) env.use } ) env lvs | _ -> assert false ) let contra_congruence env facts r = Options.exec_thread_yield (); if X.equal (fst (Uf.find_r env.uf r)) (X.top()) then new_facts_by_contra_congruence env facts r T.faux else if X.equal (fst (Uf.find_r env.uf r)) (X.bot()) then new_facts_by_contra_congruence env facts r T.vrai let congruence_closure env (facts:r Sig.facts) r1 r2 ex = Options.exec_thread_yield (); Debug.cc r1 r2; let uf, res = Uf.union env.uf r1 r2 ex in List.fold_left (fun env (p, touched, v) -> Options.exec_thread_yield (); Debug.cc_result p v touched; assert (X.is_a_leaf p); (* we look for use(p) *) let p_t, p_a = Use.find p env.use in (* we compute terms and atoms to consider for congruence *) let repr_touched = List.map (fun (x, y, ex) -> facts.touched <- Util.MI.add (X.hash x) x facts.touched; y ) touched in let st_others, sa_others = Use.congr_close_up env.use p repr_touched in (* we update use *) let nuse = Use.up_close_up env.use p v in let nuse = List.fold_left (fun nuse (r, rr, ex) -> match X.leaves rr with | _ :: _ -> nuse | [] -> Use.up_close_up nuse p one )nuse touched in Use.print nuse; (* we check the congruence of the terms. *) let env = {env with use=nuse} in SetT.iter (fun t -> congruents env facts t st_others) p_t; (*CC of preds ?*) SetA.iter (fun (a, ex) -> add_fact facts (LTerm a, ex, Sig.Other)) p_a; (*touched preds ?*) SetA.iter (fun (a, ex) -> add_fact facts (LTerm a, ex, Sig.Other)) sa_others; env ) {env with uf=uf} res module LRT = Map.Make (struct type t = LR.t * Literal.LT.t option let compare (x, y) (x', y') = let c = LR.compare x x' in if c <> 0 then c else match y, y' with | None, None -> 0 | Some _, None -> 1 | None, Some _ -> -1 | Some a, Some a' -> Literal.LT.compare a a' end) let make_unique sa = let mp = List.fold_left (fun mp ((ra, aopt ,_ ,_) as e) -> LRT.add (LR.make ra, aopt) e mp ) LRT.empty sa in LRT.fold (fun _ e acc -> e::acc)mp [] let replay_atom env sa = Options.exec_thread_yield (); let sa = make_unique sa in let relation, result = Rel.assume env.relation env.uf sa in let env = { env with relation = relation } in let env = clean_use env result.remove in env, result.assume let rec add_term env facts t ex = Options.exec_thread_yield (); (* nothing to do if the term already exists *) if Uf.mem env.uf t then env else begin Options.tool_req 3 "TR-CCX-AddTerm"; Debug.add_to_use t; (* we add t's arguments in env *) let {T.f = f; xs = xs} = T.view t in let env = List.fold_left (fun env t -> add_term env facts t ex) env xs in (* we update uf and use *) let nuf, ctx = Uf.add env.uf t in Debug.make_cst t ctx; List.iter (fun a -> add_fact facts (LTerm a, ex, Sig.Other)) ctx; (*or Ex.empty ?*) let rt, _ = Uf.find nuf t in let lvs = concat_leaves nuf xs in let nuse = Use.up_add env.use t rt lvs in (* If finitetest is used we add the term to the relation *) let rel = Rel.add env.relation nuf rt t in Use.print nuse; (* we compute terms to consider for congruence *) (* we do this only for non-atomic terms with uninterpreted head-symbol *) let st_uset = Use.congr_add nuse lvs in (* we check the congruence of each term *) let env = {uf = nuf; use = nuse; relation = rel} in congruents env facts t st_uset; env end let add env facts a ex = match A.LT.view a with | A.Pred (t1, _) -> add_term env facts t1 ex | A.Eq (t1, t2) -> let env = add_term env facts t1 ex in add_term env facts t2 ex | A.Distinct (_, lt) | A.Builtin (_, _, lt) -> let env = List.fold_left (fun env t-> add_term env facts t ex) env lt in let lvs = concat_leaves env.uf lt in (* A verifier *) List.fold_left (* add Distinct and Builtin to Use *) (fun env rx -> let st, sa = Use.find rx env.use in { env with use = Use.add rx (st,SetA.add (a, ex) sa) env.use } ) env lvs let semantic_view env (a, ex, orig) facts = match a with | LTerm a -> (* Over terms: add terms + term_canonical_view *) let env = add env facts a ex in let sa, ex = term_canonical_view env a ex in env, (sa, Some a, ex, orig) | LSem sa -> match sa with | A.Builtin _ -> (* we put it in canonical form for FM *) let sa, ex = canonical_view env sa ex in env, (sa, None, ex, orig) | _ -> (* XXX if we do canonical_view for A.Distinct, the theory of arrays will get lost *) env, (sa, None, ex, orig) let assume_eq env facts r1 r2 ex = Options.tool_req 3 "TR-CCX-Congruence"; let env = congruence_closure env facts r1 r2 ex in if Options.nocontracongru () || X.type_info r1 != Ty.Tbool then env else begin contra_congruence env facts r1; contra_congruence env facts r2; env end let assume_dist env facts lr ex = Options.tool_req 3 "TR-CCX-Distinct"; if Uf.already_distinct env.uf lr then env else {env with uf = Uf.distinct env.uf lr ex} let rec assume_equalities env choices facts = if Q.is_empty facts.equas then env, choices else begin Debug.facts facts "equalities"; let e = Q.pop facts.equas in Q.push e facts.ineqs; (*XXX also added in touched by congruence_closure*) let env, (sa, root, ex, orig) = semantic_view env e facts in Debug.assume_literal sa; let env = match sa with | A.Pred (r1,neg) -> let r2, r3 = if neg then X.bot(), X.top() else X.top(), X.bot() in if X.hash_cmp r1 r2 = 0 then env else let env = assume_eq env facts r1 r2 ex in assume_dist env facts [r1;r3] ex | A.Eq(r1, r2) -> if X.hash_cmp r1 r2 = 0 then env else assume_eq env facts r1 r2 ex | _ -> assert false in assume_equalities env choices facts end let rec assume_disequalities env choices facts = if Q.is_empty facts.diseqs then env, choices else begin Debug.facts facts "disequalities"; let e = Q.pop facts.diseqs in Q.push e facts.ineqs; let env, (sa, root, ex, orig) = semantic_view env e facts in Debug.assume_literal sa; let env = match sa with | A.Distinct (false, lr) -> assume_dist env facts lr ex | A.Distinct (true, _) -> assert false | A.Pred _ -> Q.push (LSem sa, ex, orig) facts.equas; env | _ -> assert false in if Q.is_empty facts.equas then assume_disequalities env choices facts else env, choices (* Return to give priority to equalities *) end let rec norm_queue env ineqs (facts:r Sig.facts) = if Q.is_empty facts.ineqs then env, List.rev ineqs else let e = Q.pop facts.ineqs in let env, e' = semantic_view env e facts in let ineqs = e'::ineqs in let ineqs = match e with (* for case-split, to be sure that CS is given back to relations *) | LSem ra, ex, ((Sig.CS _ | Sig.NCS _) as orig) -> (ra, None, ex, orig) :: ineqs | _ -> ineqs in norm_queue env ineqs facts let add_touched uf acc (facts:r Sig.facts) = let acc = Util.MI.fold (fun _ x acc -> let y, ex = Uf.find_r uf x in (*use terms ? *) (LR.mkv_eq x y, None, ex, Sig.Subst) :: acc) facts.touched acc in facts.touched <- Util.MI.empty; acc let rec assume_inequalities env choices facts = Options.tool_req 3 "TR-CCX-Builtin"; if Q.is_empty facts.ineqs then env, choices else begin Debug.facts facts "inequalities"; let env, ineqs = norm_queue env [] facts in let ineqs = add_touched env.uf ineqs facts in let env, l = replay_atom env ineqs in List.iter (add_fact facts) l; env, List.rev_append l choices end let rec assume_literals env choices facts = match Q.is_empty facts.equas with | false -> let env, choices = assume_equalities env choices facts in assume_literals env choices facts | true -> match Q.is_empty facts.diseqs with | false -> let env, choices = assume_disequalities env choices facts in assume_literals env choices facts | true -> match Q.is_empty facts.ineqs with | false -> let env, choices = assume_inequalities env choices facts in assume_literals env choices facts | true -> env, choices let add_term env facts t ex = let env = add_term env facts t ex in env, facts let add env facts a ex = let env = add env facts a ex in env, facts (* End: new implementation of add, add_term, assume_literals and all that *) let case_split env ~for_model = match Rel.case_split env.relation env.uf for_model with | [] when for_model -> let l, uf = Uf.assign_next env.uf in (* try to not to modify uf in the future. It's currently done only to add fresh terms in UF to avoid loops *) l, {env with uf} | l -> l, env let query env a = let ra, ex_ra = term_canonical_view env a Ex.empty in Rel.query env.relation env.uf (ra, Some a, ex_ra, Sig.Other) let new_terms env = Rel.new_terms env.relation let class_of env t = Uf.class_of env.uf t let are_equal env t1 t2 = Uf.are_equal env.uf t1 t2 let are_distinct env t1 t2 = Uf.are_distinct env.uf t1 t2 let cl_extract env = Uf.cl_extract env.uf let term_repr env t = Uf.term_repr env.uf t let get_union_find env = env.uf let print_model fmt env = let zero = ref true in let eqs, neqs = Uf.model env.uf in let rs = List.fold_left (fun acc (r, l, to_rel) -> if l != [] then begin if !zero then begin fprintf fmt "Theory:"; zero := false; end; fprintf fmt "\n %a = %a" (T.print_list_sep " = ") l X.print r; end; to_rel@acc ) [] eqs in List.iter (fun lt -> if !zero then begin fprintf fmt "Theory:"; zero := false; end; fprintf fmt "\n %a" (T.print_list_sep " <> ") lt; ) neqs; if not !zero then fprintf fmt "\n@."; Rel.print_model fmt env.relation rs end alt-ergo-1.30/src/theories/intervalCalculus.mli0000644000175000001440000000337513014515065020157 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-1.30/src/theories/arrays.mli0000644000175000001440000000362413014515065016135 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-1.30/src/theories/theory.mli0000644000175000001440000000501213014515065016137 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module type S = sig type t val empty : unit -> t (* the first int is the decision level (dlvl) and the second one is the propagation level (plvl). The facts (first argument) are sorted in decreasing order with respect to (dlvl, plvl) *) val assume : ?ordered:bool -> (Literal.LT.t * Explanation.t * int * int) list -> t -> t * Term.Set.t * int val query : Literal.LT.t -> t -> Sig.answer val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val print_model : Format.formatter -> t -> unit val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val extract_ground_terms : t -> Term.Set.t val get_real_env : t -> Ccx.Main.t val get_case_split_env : t -> Ccx.Main.t val do_case_split : t -> t * Term.Set.t val add_term : t -> Term.t -> add_in_cs:bool -> t val compute_concrete_model : t -> t end module Main : S alt-ergo-1.30/src/theories/intervals.mli0000644000175000001440000000716613014515065016650 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type t exception NotConsistent of Explanation.t exception No_finite_bound val undefined : Ty.t -> t val is_undefined : t -> bool val point : Numbers.Q.t -> Ty.t -> Explanation.t -> t val doesnt_contain_0 : t -> Sig.answer val is_positive : t -> Sig.answer val is_strict_smaller : t -> t -> bool val new_borne_sup : Explanation.t -> Numbers.Q.t -> is_le : bool -> t -> t val new_borne_inf : Explanation.t -> Numbers.Q.t -> is_le : bool -> t -> t val is_point : t -> (Numbers.Q.t * Explanation.t) option val intersect : t -> t -> t val exclude : t -> t -> t val mult : t -> t -> t val power : int -> t -> t val sqrt : t -> t val root : int -> t -> t val add : t -> t -> t val scale : Numbers.Q.t -> t -> t val sub : t -> t -> t val merge : t -> t -> t val abs : t -> t val pretty_print : Format.formatter -> t -> unit val print : Format.formatter -> t -> unit val finite_size : t -> Numbers.Q.t option val borne_inf : t -> Numbers.Q.t * Explanation.t * bool (** bool is true when bound is large. Raise: No_finite_bound if no finite lower bound *) val borne_sup : t -> Numbers.Q.t * Explanation.t * bool (** bool is true when bound is large. Raise: No_finite_bound if no finite upper bound*) val div : t -> t -> t val mk_closed : Numbers.Q.t -> Numbers.Q.t -> bool -> bool -> Explanation.t -> Explanation.t -> Ty.t -> t (** takes as argument in this order: - a lower bound - an upper bound - a bool that says if the lower bound it is large (true) or strict - a bool that says if the upper bound it is large (true) or strict - an explanation of the lower bound - an explanation of the upper bound - a type Ty.t (Tint or Treal *) type bnd = (Numbers.Q.t * Numbers.Q.t) option * Explanation.t (* - None <-> Infinity - the first number is the real bound - the second number if +1 (resp. -1) for strict lower (resp. upper) bound, and 0 for large bounds *) val bounds_of : t -> (bnd * bnd) list val contains : t -> Numbers.Q.t -> bool val add_explanation : t -> Explanation.t -> t val equal : t -> t -> bool alt-ergo-1.30/src/theories/use.mli0000644000175000001440000000410413014515065015422 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module SA : Set.S with type elt = Literal.LT.t * Explanation.t module type S = sig type t type r val empty : t val find : r -> t -> Term.Set.t * SA.t val add : r -> Term.Set.t * SA.t -> t -> t val mem : r -> t -> bool val print : t -> unit val up_add : t -> Term.t -> r -> r list -> t val congr_add : t -> r list -> Term.Set.t val up_close_up :t -> r -> r -> t val congr_close_up : t -> r -> r list -> Term.Set.t * SA.t end module Make (X : Sig.X) : S with type r = X.r alt-ergo-1.30/src/theories/intervals.ml0000644000175000001440000010607613014515065016477 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options module Z = Numbers.Z module Q = Numbers.Q module Ex = Explanation type borne = | Strict of (Q.t * Ex.t) | Large of (Q.t * Ex.t) | Pinfty | Minfty type t = { ints : (borne * borne) list; is_int : bool; expl: Ex.t } exception EmptyInterval of Ex.t exception NotConsistent of Ex.t exception No_finite_bound (*BISECT-IGNORE-BEGIN*) module Debug = struct let print_borne fmt = function | Minfty -> fprintf fmt "-inf" | Pinfty -> fprintf fmt "+inf" | Strict (v, e) | Large (v, e) -> fprintf fmt "%s" (Q.to_string v); if verbose () || proof () then fprintf fmt " %a" Ex.print e let print_interval fmt (b1,b2) = let c1, c2 = match b1, b2 with | Large _, Large _ -> '[', ']' | Large _, _ -> '[', '[' | _, Large _ -> ']', ']' | _, _ -> ']', '[' in fprintf fmt "%c%a;%a%c" c1 print_borne b1 print_borne b2 c2 let print_list fmt = function | [] -> fprintf fmt "[empty]" | e::l -> print_interval fmt e; List.iter (fprintf fmt " U %a" print_interval) l let print fmt {ints = ints; is_int = b; expl = e } = print_list fmt ints; if verbose () || proof () then fprintf fmt " %a" Ex.print e end (*BISECT-IGNORE-END*) let print = Debug.print let pretty_print = Debug.print let large_borne_of n e = Large (n, e) let strict_borne_of n e = Strict (n, e) let undefined_int = {ints = [Minfty, Pinfty]; is_int = true ; expl = Ex.empty} let undefined_real = {ints = [Minfty, Pinfty]; is_int = false; expl = Ex.empty} let undefined ty = match ty with | Ty.Tint -> undefined_int | Ty.Treal -> undefined_real | _ -> assert false let is_undefined t = match t.ints with | [Minfty, Pinfty] -> true | _ -> false let point b ty e = { ints = [Large (b, e), Large (b, e)]; is_int = ty == Ty.Tint; expl = e } let is_point { ints = l; expl = e } = match l with | [Large (v1, e1) , Large (v2, e2)] when Q.equal v1 v2 -> Some (v1, Ex.union e (Ex.union e1 e2)) | _ -> None let finite_size {ints = l; is_int = is_int} = if not is_int then None else try let acc = ref [] in List.iter (fun (b1, b2) -> match b1, b2 with | Minfty, _ | _, Pinfty -> raise Exit | Large (v1, _) , Large (v2, _) -> acc := (v1, v2) :: !acc | _, _ -> assert false )l; let res = List.fold_left (fun n (v1, v2) -> Q.add n (Q.add (Q.sub v2 v1) Q.one)) Q.zero !acc in Some res with Exit -> None let borne_inf = function | {ints = (Large (v, ex), _)::_} -> v, ex, true | {ints = (Strict (v, ex), _)::_} -> v, ex, false | _ -> raise No_finite_bound let borne_sup {ints=ints} = match List.rev ints with | (_, Large (v, ex))::_ -> v, ex, true | (_, Strict (v, ex))::_ -> v, ex, false | _ -> raise No_finite_bound let explain_borne = function | Large (_, e) | Strict (_, e) -> e | _ -> Ex.empty let add_expl_to_borne b e = if Ex.is_empty e then b else match b with | Large (n, e') -> Large (n, Ex.union e e') | Strict (n, e') -> Strict (n, Ex.union e e') | Pinfty | Minfty -> b let add_expl_zero i expl = if Ex.is_empty expl then i else let res = List.rev_map (fun x -> match x with | Large (c1, e1), Large (c2, e2) when Q.sign c1 = 0 && Q.sign c2 = 0 -> Large (Q.zero, Ex.union e1 expl), Large (Q.zero, Ex.union e2 expl) | _ -> x ) i.ints in { i with ints = List.rev res } let int_of_borne_inf b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else Q.ceiling v), e) | Strict (v, e) -> if Q.is_int v then Large (Q.add v Q.one, e) else let v' = Q.ceiling v in assert (Q.compare v' v > 0); Large (v', e) let int_of_borne_sup b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else Q.floor v), e) | Strict (v, e) -> if Q.is_int v then Large (Q.sub v Q.one, e) else let v' = Q.floor v in assert (Q.compare v' v < 0); Large (v', e) let int_bornes (l, u) = int_of_borne_inf l, int_of_borne_sup u let compare_bounds b1 ~is_low1 b2 ~is_low2 = match b1, b2 with | Minfty, Minfty | Pinfty, Pinfty -> 0 | Minfty, _ | _, Pinfty -> -1 | _, Minfty | Pinfty, _ -> 1 | Large (v1, ex1), Large (v2, ex2) -> Q.compare v1 v2 | Strict (v1, ex1), Strict (v2, ex2) -> let c = Q.compare v1 v2 in if c <> 0 then c else if is_low1 == is_low2 then 0 (* bl_bl or bu_bu *) else if is_low1 then 1 (* implies not is_low2 *) else -1 (* implies not is_low1 and is_low2 *) | Strict (v1, ex1), Large (v2, ex2) -> let c = Q.compare v1 v2 in if c <> 0 then c else if is_low1 then 1 else -1 | Large (v1, ex1), Strict (v2, ex2) -> let c = Q.compare v1 v2 in if c <> 0 then c else if is_low2 then -1 else 1 let zero_endpoint b = match b with | Large (v, _) -> Q.is_zero v | _ -> false let min_of_lower_bounds b1 b2 = if compare_bounds b1 ~is_low1:true b2 ~is_low2:true <= 0 then b1 else b2 let max_of_upper_bounds b1 b2 = if compare_bounds b1 ~is_low1:false b2 ~is_low2:false >= 0 then b1 else b2 let zero_large = Large (Q.zero, Ex.empty) let low_borne_pos_strict b = compare_bounds b ~is_low1:true zero_large ~is_low2:true > 0 let up_borne_pos_strict b = compare_bounds b ~is_low1:false zero_large ~is_low2:false > 0 let low_borne_neg_strict b = compare_bounds b ~is_low1:true zero_large ~is_low2:true < 0 let up_borne_neg_strict b = compare_bounds b ~is_low1:false zero_large ~is_low2:false < 0 let low_borne_pos_large b = compare_bounds b ~is_low1:true zero_large ~is_low2:true >= 0 let up_borne_pos_large b = compare_bounds b ~is_low1:false zero_large ~is_low2:false >= 0 let low_borne_neg_large b = compare_bounds b ~is_low1:true zero_large ~is_low2:true <= 0 let up_borne_neg_large b = compare_bounds b ~is_low1:false zero_large ~is_low2:false <= 0 (* should be removed: probably buggy when mixing lower and upper bounds *) let pos_borne b = match b with | Pinfty -> true | Minfty -> false | Strict (v, _) | Large (v, _) -> Q.sign v >= 0 (* should be removed: probably buggy when mixing lower and upper bounds *) let neg_borne b = match b with | Pinfty -> false | Minfty -> true | Strict (v, _) | Large (v, _) -> Q.sign v <= 0 (* TODO: generalize the use of this type and the function joint below to other operations on intervals *) type kind = | Empty of Explanation.t | Int of (borne * borne) let join l glob_ex = (* l should not be empty *) let rec j_aux _todo _done = match _todo, _done with | [], [] -> assert false | [], _ -> List.rev _done, None | [Empty ex], [] -> [], Some ex | (Int b) :: l, _ -> j_aux l (b :: _done) | (Empty ex) :: l, _ -> let _done = match _done with | [] -> [] | (low, up) :: r -> (low, add_expl_to_borne up ex) :: r in let _todo = match l with | [] -> [] | (Empty ex') :: r -> (Empty (Ex.union ex ex')) :: r | (Int (low, up)) :: r -> (Int (add_expl_to_borne low ex, up)) :: r in j_aux _todo _done in match j_aux l [] with | [], None -> assert false | l , None -> l | [], Some ex -> raise (NotConsistent (Ex.union ex glob_ex)); | l , Some _ -> assert false let intersect = let rec step is_int l1 l2 acc = match l1, l2 with | [], _ | _, [] -> List.rev acc | (lo1, up1)::r1, (lo2, up2)::r2 when compare_bounds up1 ~is_low1:false lo2 ~is_low2:true < 0 -> (* No overlap. (lo1, up1) is smaller *) let nexpl = Ex.union (explain_borne up1) (explain_borne lo2) in step is_int r1 l2 ((Empty nexpl) :: acc) | (lo1, up1)::r1, (lo2, up2)::r2 when compare_bounds lo1 ~is_low1:true up2 ~is_low2:false > 0 -> (* No overlap. (lo2, up2) is smaller *) let nexpl = Ex.union (explain_borne up2) (explain_borne lo1) in step is_int l1 r2 ((Empty nexpl) :: acc) | (lo1, up1)::r1, (lo2, up2)::r2 -> let cll = compare_bounds lo1 ~is_low1:true lo2 ~is_low2:true in let cuu = compare_bounds up1 ~is_low1:false up2 ~is_low2:false in if cll <= 0 && cuu >= 0 then (* (lo1, up1) subsumes (lo2, up2) *) step is_int l1 r2 ((Int (lo2,up2))::acc) (* ex of lo1 and up1 ? *) else if cll >= 0 && cuu <= 0 then (* (lo2, up2) subsumes (lo1, up1) *) step is_int r1 l2 ((Int(lo1,up1))::acc) (* ex of lo2 and up2 ? *) else if cll <= 0 && cuu <= 0 then (* lo1 <= lo2 <= up1 <= up2 *) step is_int r1 l2 ((Int(lo2,up1))::acc) (* ex of lo1 and up2 ? *) else if cll >= 0 && cuu >= 0 then (* lo2 <= lo1 <= up2 <= up1 *) step is_int l1 r2 (Int((lo1,up2))::acc) (* ex of lo2 and up1 ? *) else assert false in fun ({ints=l1; expl=e1; is_int=is_int} as uints1) {ints=l2; expl=e2} -> (*l1 and l2 are supposed to be normalized *) let expl = Ex.union e1 e2 in let l = step is_int l1 l2 [] in let res = { uints1 with ints = join l expl; expl } in assert (res.ints != []); res let new_borne_sup expl b ~is_le uints = let aux b expl = let b = (if is_le then large_borne_of else strict_borne_of) b expl in if uints.is_int then int_of_borne_sup b else b in intersect { ints = [Minfty, aux b expl]; is_int = uints.is_int; expl = Ex.empty } uints let new_borne_inf expl b ~is_le uints = let aux b expl = let b = (if is_le then large_borne_of else strict_borne_of) b expl in if uints.is_int then int_of_borne_inf b else b in intersect { ints = [aux b expl, Pinfty]; is_int = uints.is_int; expl = Ex.empty } uints type interval_class = | P | M | N | Z let class_of l u = if zero_endpoint l && zero_endpoint u then Z else if pos_borne l && pos_borne u then begin assert (up_borne_pos_strict u); P end else if neg_borne l && neg_borne u then begin assert (low_borne_neg_strict l); N end else begin assert (low_borne_neg_strict l); assert (up_borne_pos_strict u); M end let union_bornes is_int l = let rec aux is_int l acc = match l with | [] -> acc | [e] -> e::acc | (l1, u1)::((l2, u2)::r as r2) -> if compare_bounds u1 ~is_low1:false l2 ~is_low2:true < 0 then match is_int, u1, l2 with | true, Large(x,_), Large (y, _) when Q.equal (Q.sub y x) Q.one -> aux is_int ((l1, u2)::r) acc | _ -> (* the only case where we put things in acc *) aux is_int r2 ((l1, u1)::acc) else if compare_bounds u1 ~is_low1:false u2 ~is_low2:false > 0 then aux is_int ((l1, u1)::r) acc else aux is_int ((l1, u2)::r) acc in List.rev (aux is_int l []) let union_intervals uints = let l = List.fast_sort (fun (l1, _) (l2, _) -> compare_bounds l1 ~is_low1:true l2 ~is_low2:true) uints.ints in {uints with ints = union_bornes uints.is_int l} let minus_borne = function | Minfty -> Pinfty | Pinfty -> Minfty | Large (v, e) -> Large (Q.minus v, e) | Strict (v, e) -> Strict (Q.minus v, e) let rev_normalize_int_bounds rl ex n = let l = List.rev_map (fun b -> let b = int_bornes b in match b with | Large (v, ex1), Large (w, ex2) when Q.compare w v < 0 -> Empty (Ex.union ex1 ex2) | Strict (v, ex1), Large (w, ex2) | Large (v, ex1) , Strict (w, ex2) | Strict (v, ex1), Strict (w, ex2) when Q.compare w v <= 0 -> Empty (Ex.union ex1 ex2) | _ -> Int b ) rl in if Q.compare n Q.zero > 0 (* !!! this test should be checked *) then join l ex else List.rev (join (List.rev l) ex) let exclude = let rec complement l prev acc = match l with | (b1,b2)::r -> let bu = match b1 with | Strict v -> Large v | Large v -> Strict v | _ -> b1 in let bl = match b2 with | Strict v -> Large v | Large v -> Strict v | _ -> b2 in if bu == Minfty then complement r bl acc else complement r bl ((prev, bu)::acc) | [] -> List.rev (if prev == Pinfty then acc else (prev, Pinfty)::acc) in fun uints1 uints2 -> let l_c = complement uints1.ints Minfty [] in let l_c = if uints2.is_int then List.rev (List.rev_map int_bornes l_c) else l_c in let uints1_c = union_intervals {uints1 with ints = l_c} in intersect uints1_c uints2 let scale_interval_zero n (b1, b2) = assert (Q.sign n = 0); Large (Q.zero, explain_borne b1), Large (Q.zero, explain_borne b2) let scale_borne_non_zero n b = assert (Q.sign n > 0); match b with | Pinfty | Minfty -> b | Large (v, e) -> Large (Q.mult n v, e) | Strict (v, e) -> Strict (Q.mult n v, e) let scale_interval_pos n (b1, b2) = scale_borne_non_zero n b1, scale_borne_non_zero n b2 let scale_interval_neg n (b1, b2) = minus_borne (scale_borne_non_zero (Q.minus n) b2), minus_borne (scale_borne_non_zero (Q.minus n) b1) let scale n uints = Options.tool_req 4 "TR-Arith-Axiomes scale"; if Q.equal n Q.one then uints else let sgn = Q.sign n in let aux = if sgn = 0 then scale_interval_zero else if sgn > 0 then scale_interval_pos else scale_interval_neg in let rl = List.rev_map (aux n) uints.ints in let l = if uints.is_int then rev_normalize_int_bounds rl uints.expl n else List.rev rl in let res = union_intervals { uints with ints = l } in assert (res.ints != []); res let add_borne b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> assert false | Minfty, _ | _, Minfty -> Minfty | Pinfty, _ | _, Pinfty -> Pinfty | Large (v1, e1), Large (v2, e2) -> Large (Q.add v1 v2, Ex.union e1 e2) | (Large (v1, e1) | Strict (v1, e1)), (Large (v2, e2) | Strict (v2, e2)) -> Strict (Q.add v1 v2, Ex.union e1 e2) let add_interval is_int l (b1,b2) = List.fold_right (fun (b1', b2') l -> let l1 = ((add_borne b1 b1'),(add_borne b2 b2'))::l in union_bornes is_int (l1) ) l [] let add {ints = l1; is_int = is_int; expl = e1} {ints = l2; expl = e2}= let l = List.fold_left (fun l bs -> let i = add_interval is_int l1 bs in i@l) [] l2 in let res = union_intervals { ints = l ; is_int; expl = Ex.union e1 e2 } in assert (res.ints != []); res let sub i1 i2 = add i1 (scale Q.m_one i2) let merge i1 i2 = union_intervals {ints = List.rev_append i1.ints i2.ints; is_int = i1.is_int; expl = Explanation.union i1.expl i2.expl} let contains i q = List.exists (fun (b1, b2) -> begin match b1 with | Minfty -> true | Pinfty -> assert false | Large(v, _) -> Q.compare v q <= 0 | Strict(v, _) -> Q.compare v q < 0 end && begin match b2 with | Pinfty -> true | Minfty -> assert false | Large(v, _) -> Q.compare v q >= 0 | Strict(v, _) -> Q.compare v q > 0 end ) i.ints let doesnt_contain_0 = let rec explain_no_zero l = match l with | [] -> assert false | (b1, b2) :: l -> let pos_strict_b1 = low_borne_pos_strict b1 in let pos_strict_b2 = up_borne_pos_strict b2 in if pos_strict_b1 && pos_strict_b2 then (* there is no negative values at all *) Sig.Yes (Ex.union (explain_borne b1) (explain_borne b2), []) else begin (* we know l does not contain 0. So, these asserts should hold *) assert (not pos_strict_b1); assert (not pos_strict_b2); assert (low_borne_neg_strict b1); assert (up_borne_neg_strict b2); match l with | [] -> (* there is no positive values at all *) Sig.Yes (Ex.union (explain_borne b1) (explain_borne b2), []) | (c1,_)::_ -> if low_borne_pos_strict c1 then Sig.Yes (Ex.union (explain_borne b2) (explain_borne c1), []) else explain_no_zero l end in fun int -> if contains int Q.zero then Sig.No else explain_no_zero int.ints let is_positive {ints=ints; expl=expl} = match ints with | [] -> assert false | (lb,_)::_ -> if pos_borne lb then Sig.Yes (expl, []) else Sig.No let root_default_num v n = if n = 2 then Q.sqrt_default v else Q.root_default v n let root_exces_num v n = if n = 2 then Q.sqrt_excess v else Q.root_excess v n (* should be removed and replaced with compare_bounds, with makes distinction between lower and upper bounds *) let compare_bornes b1 b2 = match b1, b2 with | Minfty, Minfty | Pinfty, Pinfty -> 0 | Minfty, _ | _, Pinfty -> -1 | Pinfty, _ | _, Minfty -> 1 | Strict (v1, _), Strict (v2, _) | Large (v1, _), Large (v2, _) | Strict (v1, _), Large (v2, _) | Large (v1, _), Strict (v2, _) -> Q.compare v1 v2 let is_strict_smaller = let rec aux l1 l2 nb_eq sz_l1 sz_l2 = match l1, l2 with [], _ -> true, nb_eq, sz_l1, (sz_l2 + List.length l2) | _, [] -> false, nb_eq, (sz_l1 + List.length l1), sz_l2 | b1::r1, b2::r2 -> let lo1, up1 = b1 in let lo2, up2 = b2 in let c_l1_l2 = compare_bounds lo1 ~is_low1:true lo2 ~is_low2:true in let c_u1_u2 = compare_bounds up1 ~is_low1:false up2 ~is_low2:false in let c_l1_u2 = compare_bounds lo1 ~is_low1:true up2 ~is_low2:false in let c_u1_l2 = compare_bounds up1 ~is_low1:false lo2 ~is_low2:true in if c_l1_l2 = 0 && c_u1_u2 = 0 then aux r1 r2 (nb_eq + 1) (sz_l1 + 1) (sz_l2 + 1) else if c_l1_l2 >= 0 && c_u1_u2 <= 0 then (* without being equal *) (* b1 \subset b2! look for inclusion of r1 in l2 *) aux r1 l2 nb_eq (sz_l1 + 1) sz_l2 else if c_l1_u2 >= 0 then (*ignore b2, and look for inclusion of l1 in r2*) aux l1 r2 nb_eq sz_l1 (sz_l2 + 1) else if c_u1_l2 < 0 then raise Exit(* b1 is not included in any part of l2*) else if c_l1_l2 <= 0 && c_u1_u2 >= 0 then (* without being equal *) raise Exit (*no inclusion, we have b2 \subset b1 !! *) else if c_l1_l2 < 0 && c_u1_u2 < 0 || c_l1_l2 > 0 && c_u1_u2 > 0 then raise Exit (* intersection and differences are not empty *) else assert false in fun i1 i2 -> try let res, nb_eq, sz_l1, sz_l2 = aux i1.ints i2.ints 0 0 0 in (* if res is true, we should check that i1 and i2 are not equal *) res && (sz_l1 <> sz_l2 || nb_eq <> sz_l1) with Exit -> false let mult_borne b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> assert false | Minfty, b | b, Minfty -> if compare_bornes b (large_borne_of Q.zero Ex.empty) = 0 then b else if pos_borne b then Minfty else Pinfty | Pinfty, b | b, Pinfty -> if compare_bornes b (large_borne_of Q.zero Ex.empty) = 0 then b else if pos_borne b then Pinfty else Minfty | Strict (_, e1), Large (v, e2) | Large (v, e1), Strict (_, e2) when Q.is_zero v -> Large (Q.zero, Ex.union e1 e2) | Strict (v1, e1), Strict (v2, e2) | Strict (v1, e1), Large (v2, e2) | Large (v1, e1), Strict (v2, e2) -> Strict (Q.mult v1 v2, Ex.union e1 e2) | Large (v1, e1), Large (v2, e2) -> Large (Q.mult v1 v2, Ex.union e1 e2) let mult_borne_inf b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> Minfty | _, _ -> mult_borne b1 b2 let mult_borne_sup b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> Pinfty | _, _ -> mult_borne b1 b2 let mult_bornes (a,b) (c,d) = (* see ../extra/intervals_mult.png *) (* put the explanation of both bounds for multiplication. Putting just one of them is probably incorrect. When a bound is [0,0], put the explanation of that bound instead of empty. TODO: make a deeper study!!!*) let ex_a_b = Ex.union (explain_borne a) (explain_borne b) in let ex_c_d = Ex.union (explain_borne c) (explain_borne d) in let all_ex = Ex.union ex_a_b ex_c_d in match class_of a b, class_of c d with | P, P -> mult_borne_inf a c, mult_borne_sup b d, all_ex | P, M -> mult_borne_inf b c, mult_borne_sup b d, all_ex | P, N -> mult_borne_inf b c, mult_borne_sup a d, all_ex | M, P -> mult_borne_inf a d, mult_borne_sup b d, all_ex | M, M -> min_of_lower_bounds (mult_borne_inf a d) (mult_borne_inf b c), max_of_upper_bounds (mult_borne_sup a c) (mult_borne_sup b d), all_ex | M, N -> mult_borne_inf b c, mult_borne_sup a c, all_ex | N, P -> mult_borne_inf a d, mult_borne_sup b c, all_ex | N, M -> mult_borne_inf a d, mult_borne_sup a c, all_ex | N, N -> mult_borne_inf b d, mult_borne_sup a c, all_ex | Z, (P | M | N | Z) -> (a, b, ex_a_b) | (P | M | N ), Z -> (c, d, ex_c_d) let rec power_borne_inf p b = match p with | 1 -> b | p -> mult_borne_inf b (power_borne_inf (p-1) b) let rec power_borne_sup p b = match p with | 1 -> b | p -> mult_borne_sup b (power_borne_sup (p-1) b) let max_merge b1 b2 = let ex = Ex.union (explain_borne b1) (explain_borne b2) in let max = max_of_upper_bounds b1 b2 in match max with | Minfty | Pinfty -> max | Large (v, _) -> Large (v, ex) | Strict (v, _) -> Strict (v, ex) let power_bornes p (b1,b2) = if neg_borne b1 && pos_borne b2 then match p with | 0 -> assert false | p when p mod 2 = 0 -> (* max_merge to have explanations !!! *) let m = max_merge (power_borne_sup p b1) (power_borne_sup p b2) in (Large (Q.zero, Ex.empty), m) | _ -> (power_borne_inf p b1, power_borne_sup p b2) else if pos_borne b1 && pos_borne b2 then (power_borne_inf p b1, power_borne_sup p b2) else if neg_borne b1 && neg_borne b2 then match p with | 0 -> assert false | p when p mod 2 = 0 -> (power_borne_inf p b2, power_borne_sup p b1) | _ -> (power_borne_inf p b1, power_borne_sup p b2) else assert false let int_div_of_borne_inf min_f b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else (*Q.floor*) min_f v), e) | Strict (v, e) -> (* this case really happens ?? *) if Q.is_int v then Large (Q.add v Q.one, e) else let v' = (*Q.floor*) min_f v in (* correct ? *) assert (Q.compare v' v > 0); Large (v', e) let int_div_of_borne_sup max_f b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else (*Q.floor*) max_f v), e) | Strict (v, e) -> (* this case really happens ?? *) if Q.is_int v then Large (Q.sub v Q.one, e) else let v' = (*Q.floor*) max_f v in (* correct ? *) assert (Q.compare v' v < 0); Large (v', e) (* we use int_div_bornes for division of integer intervals instead of int_bornes because the div op is Euclidean division is this case *) let int_div_bornes min_f max_f l u = int_div_of_borne_inf min_f l, int_div_of_borne_sup max_f u let mult u1 u2 = Options.tool_req 4 "TR-Arith-Axiomes mult"; let resl, expl = List.fold_left (fun (l', expl) b1 -> List.fold_left (fun (l, ex) b2 -> let bl, bu, ex' = mult_bornes b1 b2 in let bl = add_expl_to_borne bl ex' in let bu = add_expl_to_borne bu ex' in (bl, bu)::l, Ex.union ex ex') (l', expl) u2.ints) ([], Ex.empty) u1.ints in let res = union_intervals { ints= resl; is_int = u1.is_int; expl = Ex.union expl (Ex.union u1.expl u2.expl) } in assert (res.ints != []); res let power n u = Options.tool_req 4 "TR-Arith-Axiomes power"; let l = List.map (power_bornes n) u.ints in union_intervals { u with ints = l } let root_default_borne is_int x n = match x with | Pinfty -> Pinfty | Minfty -> Minfty | Large (v, e) | Strict (v, e) -> let sign, s = if Q.sign v >= 0 then (fun q -> q), root_default_num v n else Q.minus, root_exces_num (Q.minus v) n in match s with | None -> Minfty | Some s -> let s = sign s in if is_int then let cs = Q.ceiling s in let cs2 = Q.power cs n in if Q.compare v cs2 <= 0 then Large (cs, e) else Large (Q.add cs Q.one, e) else Large (s, e) let root_exces_borne is_int x n = match x with | Pinfty -> Pinfty | Minfty -> Minfty | Large (v, e) | Strict (v, e) -> let sign, s = if Q.sign v >= 0 then (fun d -> d), root_exces_num v n else Q.minus, root_default_num (Q.minus v) n in match s with | None -> Pinfty | Some s -> let s = sign s in if is_int then let cs = Q.floor s in let cs2 = Q.power cs n in if Q.compare v cs2 >= 0 then Large (cs, e) else Large (Q.sub cs Q.one, e) else Large (s, e) let sqrt_interval is_int (l, ex) (b1,b2) = let l1 = minus_borne (root_exces_borne is_int b2 2) in let u1 = minus_borne (root_default_borne is_int b1 2) in let l2 = root_default_borne is_int b1 2 in let u2 = root_exces_borne is_int b2 2 in let c1 = compare_bornes l1 u1 in let c2 = compare_bornes l2 u2 in if c1 > 0 then if c2 > 0 then l, Ex.union ex (Ex.union (explain_borne b1) (explain_borne b2)) else (l2,u2)::l, ex else if c2 > 0 then (l1, u1)::l, ex else (union_bornes is_int [(l1,u1); (l2, u2)]) @ l, ex let sqrt {ints = l; is_int = is_int; expl} = Options.tool_req 4 "TR-Arith-Axiomes sqrt"; let l, expl = List.fold_left (sqrt_interval is_int) ([], expl) l in if l == [] then raise (NotConsistent expl); let res = union_intervals { ints = l; is_int; expl} in assert (res.ints != []); res let root_interval is_int (b1,b2) n = let u,l = (root_default_borne is_int b1 n, root_exces_borne is_int b2 n) in if compare_bornes u l <= 0 then Int(u,l) else Empty (Ex.union (explain_borne b1) (explain_borne b2)) let rec root n ({ints = l; is_int = is_int; expl } as u) = Options.tool_req 4"TR-Arith-Axiomes root"; if n mod 2 = 0 then root (n/2) (sqrt u) else let l = List.rev_map (fun bs -> root_interval is_int bs n) l in let l = join (List.rev l) expl in let res = union_intervals {u with ints = l; is_int = is_int} in assert (res.ints != []); res let inv_borne_inf b is_int ~other = match b with | Pinfty -> assert false | Minfty -> if is_int then Large (Q.zero, explain_borne other) else Strict (Q.zero, explain_borne other) | Strict (c, e) | Large (c, e) when Q.sign c = 0 -> Pinfty | Strict (v, e) -> Strict (Q.div Q.one v, e) | Large (v, e) -> Large (Q.div Q.one v, e) let inv_borne_sup b is_int ~other = match b with | Minfty -> assert false | Pinfty -> if is_int then Large (Q.zero, explain_borne other) else Strict (Q.zero, explain_borne other) | Strict (c, e) | Large (c, e) when Q.sign c = 0 -> Minfty | Strict (v, e) -> Strict (Q.div Q.one v, e) | Large (v, e) -> Large (Q.div Q.one v, e) let inv_bornes (l, u) is_int = inv_borne_sup u is_int ~other:l, inv_borne_inf l is_int ~other:u let inv ({ints=l; is_int=is_int} as u) = match doesnt_contain_0 u with | Sig.No -> { u with ints = [Minfty, Pinfty] } | Sig.Yes (ex, _) -> let l' = List.fold_left (fun acc (l,u) -> let l = add_expl_to_borne l ex in let u = add_expl_to_borne u ex in (inv_bornes (l, u) is_int) :: acc ) [] l in assert (l' != []); (* ! SHOULD NOT try to simplify here if is_int is true *) union_intervals { u with ints = l' } type sign_of_interval = Zero | Pos | Neg | Mixed let sign_of_interval {ints} = match ints, List.rev ints with | [], _ | _, [] -> assert false | (inf, _)::_, (_,sup)::_ -> match inf, sup with | Pinfty, _ | _, Minfty -> assert false | Minfty, Pinfty -> Mixed | Large(v,_), Large(v',_) -> if Q.compare v Q.zero > 0 then Pos else if Q.compare v' Q.zero < 0 then Neg else if Q.is_zero v && Q.is_zero v' then Zero else Mixed | (Strict(v,_) | Large(v,_)), (Strict(v',_) | Large(v',_)) -> if Q.compare v Q.zero >= 0 then Pos else if Q.compare v' Q.zero <= 0 then Neg else Mixed | (Strict(v,_) | Large(v,_)), Pinfty -> if Q.compare v Q.zero >= 0 then Pos else Mixed | Minfty, (Strict(v',_) | Large(v',_)) -> if Q.compare v' Q.zero <= 0 then Neg else Mixed let div i1 i2 = Options.tool_req 4 "TR-Arith-Axiomes div"; let inv_i2 = inv i2 in if is_undefined inv_i2 then inv_i2 else let i1 = match doesnt_contain_0 i2 with | Sig.Yes (ex, _) -> add_expl_zero i1 ex | Sig.No -> i1 in let ({ints=l; is_int=is_int} as i) = mult i1 inv_i2 in assert (l != []); if is_int then (* not just int_bornes because it's Euclidean division *) let min_f, max_f = match sign_of_interval i2 with | Zero -> assert false (* inv_i2 is not undefined *) | Pos -> Q.floor, Q.floor | Neg -> Q.ceiling, Q.ceiling | Mixed -> Q.floor, Q.ceiling in let rl = List.rev_map (fun (l,u) -> int_div_bornes min_f max_f l u) l in union_intervals { i with ints = List.rev rl } else { i with ints = l } let abs = let zero_inf_r = new_borne_inf Ex.empty Q.zero true (undefined Ty.Treal) in let zero_inf_i = new_borne_inf Ex.empty Q.zero true (undefined Ty.Tint) in fun i -> let xx = if i.is_int then zero_inf_i else zero_inf_r in intersect (merge i (scale Q.m_one i)) xx let mk_closed l u llarge ularge lexp uexp ty = let lb = if llarge then Large(l, lexp) else Strict (l, lexp) in let ub = if ularge then Large(u, uexp) else Strict (u, uexp) in { ints = [lb, ub]; is_int = ty == Ty.Tint; expl = Ex.union lexp uexp } type bnd = (Numbers.Q.t * Numbers.Q.t) option * Explanation.t let bnd_of_borne b ex0 low = match b with | Pinfty when not low -> None, ex0 | Minfty when low -> None, ex0 | Pinfty | Minfty -> assert false | Large (c, ex) -> Some (c, Q.zero), Ex.union ex0 ex | Strict (c, ex) -> Some (c, if low then Q.one else Q.m_one), Ex.union ex0 ex let bounds_of env = let ex = env.expl in match env.ints with | [] -> [(None, ex), (None, ex)] | l -> List.rev (List.rev_map (fun (b1, b2) -> bnd_of_borne b1 ex true, bnd_of_borne b2 ex false) l) let add_explanation i ex = if Ex.is_empty ex then i else let rl = List.rev_map (fun (l, u) -> add_expl_to_borne l ex, add_expl_to_borne u ex) i.ints in {i with ints = List.rev rl; expl = Ex.union i.expl ex} let equal i1 i2 = try List.iter2 (fun (b1,c1) (b2,c2) -> if compare_bounds b1 ~is_low1:true b2 ~is_low2:true <> 0 || compare_bounds c1 ~is_low1:false c2 ~is_low2:false <> 0 then raise Exit )i1.ints i2.ints; true with Exit | Invalid_argument _ -> false (*****************) (* Some debug code for Intervals: commented by default let no_inclusion = let not_included (b1, c1) (b2, c2) = not ( compare_bounds b1 ~is_low1:true b2 ~is_low2:true >= 0 && compare_bounds c1 ~is_low1:false c2 ~is_low2:false <= 0 ) in let b_inc_list d l = List.iter (fun e -> assert (not_included d e); assert (not_included e d) ) l in let rec aux todo = match todo with | [] -> assert false | [e] -> () | d::l -> b_inc_list d l; aux l in fun i -> (*fprintf fmt "[no_inclusion] i = %a@." print i;*) aux i.ints let not_mergeable = let rec aux is_int l = match l with | [] -> assert false | [e] -> () | (_,a)::(((b,_)::_) as l) -> begin match a, b with | Minfty, _ | _, Pinfty -> assert false (*should not happen*) | Pinfty, _ | _, Minfty -> assert false (*should not happen or not norm*) | Large(q1,_) , Large(q2,_) -> assert (Q.compare q1 q2 < 0); (* otherwise, we can merge *) if is_int then (* the gap between q1 and q2 should be > 1. Otherwise, we can merge *) assert (Q.compare (Q.sub q2 q1) Q.one > 0) | Strict(q1,_), Large(q2,_) -> assert (not is_int); assert (Q.compare q1 q2 < 0) (* otherwise, we can merge *) | Large(q1,_) , Strict(q2,_) -> assert (not is_int); assert (Q.compare q1 q2 < 0) (* otherwise, we can merge *) | Strict(q1,_) , Strict(q2,_) -> assert (not is_int); assert (Q.compare q1 q2 <= 0) (* otherwise, we can merge *) end; aux is_int l; in fun i -> (*fprintf fmt "[no_mergeable] i = %a@." print i;*) aux i.is_int i.ints let assert_is_normalized i = not_mergeable i; no_inclusion i; i let exclude i j = try let k = exclude i j in k |> assert_is_normalized with Assert_failure _ -> assert false let intersect i j = try let k = intersect i j in k |> assert_is_normalized with Assert_failure _ -> assert false let mult i j = try mult i j |> assert_is_normalized with Assert_failure _ -> assert false let power i j = try power i j |> assert_is_normalized with Assert_failure _ -> assert false let sqrt i = try sqrt i |> assert_is_normalized with Assert_failure _ -> assert false let root n i = try root n i |> assert_is_normalized with Assert_failure _ -> assert false let add i j = try (*fprintf fmt "@.i = %a@." print i; fprintf fmt "j = %a@." print j;*) let k = add i j in (*fprintf fmt "res = %a@." print k;*) k |> assert_is_normalized with Assert_failure _ -> assert false let scale q i = try scale q i |> assert_is_normalized with Assert_failure _ -> assert false let sub i j = try sub i j |> assert_is_normalized with Assert_failure _ -> assert false let merge i j = try merge i j |> assert_is_normalized with Assert_failure _ -> assert false let abs i = try abs i |> assert_is_normalized with Assert_failure _ -> assert false let div i j = try div i j |> assert_is_normalized with Assert_failure _ -> assert false *) alt-ergo-1.30/src/theories/bitv.ml0000644000175000001440000005657413014515065015443 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Sig module Sy = Symbols module T = Term type sort_var = A | B | C type tvar = { var : int ; sorte : sort_var } type 'a xterm = Var of tvar | Alien of 'a type 'a alpha_term = { bv : 'a; sz : int; } type 'a simple_term_aux = | Cte of bool | Other of 'a xterm | Ext of 'a xterm * int * int * int (*// id * size * i * j //*) type 'a simple_term = ('a simple_term_aux) alpha_term type 'a abstract = ('a simple_term) list (* for the solver *) type solver_simple_term_aux = | S_Cte of bool | S_Var of tvar type solver_simple_term = solver_simple_term_aux alpha_term module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak(X : ALIEN) = struct type t = X.r abstract type r = X.r let name = "bitv" let is_mine_symb = function | Sy.Bitv _ | Sy.Op (Sy.Concat | Sy.Extract) -> true | _ -> false let embed r = match X.extract r with | None -> begin match X.type_info r with | Ty.Tbitv n -> [{bv = Other (Alien r) ; sz = n}] | _ -> assert false end | Some b -> b let err = err_formatter let compare_xterm xt1 xt2 = match xt1,xt2 with | Var v1, Var v2 -> let c1 = compare v1.sorte v2.sorte in if c1 <> 0 then c1 else -(compare v1.var v2.var) (* on inverse le signe : les variables les plus fraiches sont les plus jeunes (petites)*) | Alien t1, Alien t2 -> X.str_cmp t1 t2 | Var v, Alien t -> 1 | Alien t, Var v -> -1 let compare_simple_term st1 st2 = if st1.sz <> st2.sz then st1.sz - st2.sz else begin match st1.bv,st2.bv with | Cte b,Cte b' -> compare b b' | Cte false , _ | _ , Cte true -> -1 | _ , Cte false | Cte true,_ -> 1 | Other t1 , Other t2 -> compare_xterm t1 t2 | _ , Other _ -> -1 | Other _ , _ -> 1 | Ext(t1,s1,i1,_) , Ext(t2,s2,i2,_) -> let c1 = compare s1 s2 in if c1<>0 then c1 else let c2 = compare i1 i2 in if c2 <> 0 then c2 else compare_xterm t1 t2 end module ST_Set = Set.Make ( struct type t = solver_simple_term let compare st1 st2 = if st1.sz <> st2.sz then st1.sz - st2.sz else begin match st1.bv,st2.bv with | S_Cte b, S_Cte b' -> compare b b' | S_Cte false, _ | _, S_Cte true -> -1 | _ , S_Cte false | S_Cte true,_ -> 1 | S_Var v1, S_Var v2 -> let c1 = compare v1.sorte v2.sorte in if c1 <> 0 then c1 else compare v1.var v2.var end end) module Canonizer = struct type term_aux = | I_Cte of bool | I_Other of X.r xterm | I_Ext of term * int * int | I_Comp of term * term and term = term_aux alpha_term (** **) let rec alpha t = match t.bv with |I_Cte _ -> [t] |I_Other _ -> [t] |I_Comp (t1,t2) -> (alpha t1)@(alpha t2) |I_Ext(t',i,j) -> begin match t'.bv with |I_Cte _ -> [{t' with sz = j-i+1}] |I_Other _ -> [t] |I_Ext(t'',k,_) -> alpha {t with bv = I_Ext(t'',i+k,j+k)} |I_Comp(u,v) when j < v.sz -> alpha{t with bv =I_Ext(v,i,j)} |I_Comp(u,v) when i >= v.sz -> alpha{t with bv=I_Ext(u,i-v.sz,j-v.sz)} |I_Comp(u,v) -> (alpha {sz = j-v.sz+1 ; bv = I_Ext(u,0,j-v.sz)}) @(alpha{sz = v.sz-i ; bv = I_Ext(v,i,v.sz-1)}) end (** **) let rec beta lt = let simple_t st = match st.bv with |I_Cte b -> {bv = Cte b ; sz = st.sz} |I_Other x -> {bv = Other x ; sz = st.sz} |I_Ext(t',i,j) -> begin match t'.bv with |I_Other v -> let siz = j-i+1 in {sz=siz ; bv =if siz=t'.sz then Other v else Ext(v,t'.sz,i,j)} |I_Comp _ |I_Ext _ |I_Cte _ -> assert false end |I_Comp(_,_) -> assert false in match lt with |[] -> [] (*on peut passer de 2 elts a 0 elts*) |[s] -> [simple_t s] |s::t::tl' -> begin match s.bv , t.bv with |I_Cte b1,I_Cte b2 when b1=b2 ->beta({s with sz=s.sz+t.sz}::tl') |I_Ext(d1,i,j),I_Ext(d2,k,l) when d1=d2 && l=i-1 -> let tmp = {sz = s.sz + t.sz ; bv = I_Ext(d1,k,j)} in if k=0 then (simple_t tmp)::(beta tl') else beta (tmp::tl') |_ -> (simple_t s)::(beta (t::tl')) end (** **) let sigma term = beta (alpha term) let bitv_to_icomp = List.fold_left (fun ac bt ->{ bv = I_Comp (ac,bt) ; sz = bt.sz + ac.sz }) let string_to_bitv s = let tmp = ref[] in String.iter(fun car -> tmp := (car<>'0',1)::(!tmp)) s; let rec f_aux l acc = match l with | [] -> assert false | [(b,n)] -> { sz = n ; bv = I_Cte b }::acc | (b1,n)::(b2,m)::r when b1 = b2 -> f_aux ((b1,n+m)::r) acc | (b1,n)::(b2,m)::r -> (f_aux ((b2,m)::r)) ({ sz = n ; bv = I_Cte b1 }::acc) in let res = f_aux (!tmp) [] in bitv_to_icomp (List.hd res) (List.tl res) let make t = let rec make_rec t' ctx = match T.view t' with | {T.f = Sy.Bitv s } -> string_to_bitv s, ctx | {T.f = Sy.Op Sy.Concat ; xs = [t1;t2] ; ty = Ty.Tbitv n} -> let r1, ctx = make_rec t1 ctx in let r2, ctx = make_rec t2 ctx in { bv = I_Comp (r1, r2) ; sz = n }, ctx | {T.f = Sy.Op Sy.Extract; xs = [t1;ti;tj] ; ty = Ty.Tbitv n} -> begin match T.view ti , T.view tj with | { T.f = Sy.Int i } , { T.f = Sy.Int j } -> let i = int_of_string i.Hashcons.node in let j = int_of_string j.Hashcons.node in let r1, ctx = make_rec t1 ctx in { sz = j - i + 1 ; bv = I_Ext (r1,i,j)}, ctx | _ -> assert false end | {T.ty = Ty.Tbitv n} -> let r', ctx' = X.make t' in let ctx = ctx' @ ctx in {bv = I_Other (Alien r') ; sz = n}, ctx | _ -> assert false in let r, ctx = make_rec t [] in sigma r, ctx end (*BISECT-IGNORE-BEGIN*) module Debug = struct open Canonizer let print_tvar fmt ({var=v;sorte=s},sz) = fprintf fmt "%s_%d[%d]@?" (match s with | A -> "a" | B -> "b" | C -> "c") v sz let rec print_I_ast fmt ast = match ast.bv with | I_Cte b -> fprintf fmt "%d[%d]@?" (if b then 1 else 0) ast.sz | I_Other (Alien t) -> fprintf fmt "%a[%d]@?" X.print t ast.sz | I_Other (Var tv) -> fprintf fmt "%a@?" print_tvar (tv,ast.sz) | I_Ext (u,i,j) -> fprintf fmt "%a<%d,%d>@?" print_I_ast u i j | I_Comp(u,v) -> fprintf fmt "@[(%a * %a)@]" print_I_ast u print_I_ast v let print fmt ast = match ast.bv with | Cte b -> fprintf fmt "%d[%d]@?" (if b then 1 else 0) ast.sz | Other (Alien t) -> fprintf fmt "%a@?" X.print t | Other (Var tv) -> fprintf fmt "%a@?" print_tvar (tv,ast.sz) | Ext (Alien t,sz,i,j) -> fprintf fmt "%a@?" X.print t; fprintf fmt "<%d,%d>@?" i j | Ext (Var tv,sz,i,j) -> fprintf fmt "%a@?" print_tvar (tv,ast.sz); fprintf fmt "<%d,%d>@?" i j let print_C_ast fmt = function [] -> assert false | x::l -> print fmt x; List.iter (fprintf fmt " @@ %a" print) l let print_s fmt ast = match ast.bv with | S_Cte b -> fprintf fmt "%d[%d]@?" (if b then 1 else 0) ast.sz | S_Var tv -> fprintf fmt "%a@?" print_tvar (tv,ast.sz) let print_S_ast fmt = function [] -> assert false | x::l -> print_s fmt x; List.iter (fprintf fmt " @@ %a" print_s) l let print_sliced_sys fmt l = fprintf fmt "\nSlicing :\n"; List.iter (fun (a,b) -> fprintf fmt " %a == %a\n" print a print b) l let print_c_solve_res fmt l = fprintf fmt "\n(map)c_solve :\n"; List.iter (fun (a,b) -> fprintf fmt " %a == %a\n" print a print_S_ast b) l let print_partition_res fmt l = fprintf fmt "\npartition :\n"; List.iter (fun (t,cte_l) -> fprintf fmt " %a%a \n" print t (fun fmt -> List.iter (fun l' -> fprintf fmt " == %a" print_S_ast l')) cte_l) l let print_final_solution fmt l = fprintf fmt "\nSolution :\n"; List.iter (fun (a,value) -> fprintf fmt " %a = %a \n" print a print_C_ast value ) l; fprintf fmt "@." end (*BISECT-IGNORE-END*) module Solver = struct exception Valid let add elt l = if List.mem elt l then l else elt::l let get_vars = List.fold_left (fun ac st -> match st.bv with |Other v |Ext(v,_,_,_) -> add v ac |_ -> ac )[] let st_slice st siz = let siz_bis = st.sz - siz in match st.bv with |Cte b -> {st with sz = siz},{st with sz = siz_bis} |Other x -> let s1 = Ext(x,st.sz, siz_bis, st.sz - 1) in let s2 = Ext(x,st.sz, 0, siz_bis - 1) in {bv = s1 ; sz = siz},{bv = s2 ; sz = siz_bis} |Ext(x,s,p,q) -> let s1 = Ext(x,s,p+siz_bis,q) in let s2 = Ext(x,s,p,p+siz_bis-1) in {bv = s1 ; sz = siz},{bv = s2 ; sz = siz_bis} let slice t u = let f_add (s1,s2) acc = if (s1 = s2 || List.mem (s1,s2) acc || List.mem (s2,s1) acc) then acc else (s1,s2)::acc in let rec f_rec acc = function |[],[] | _,[] | [],_ -> assert false |[s1],[s2] ->if s1.sz<>s2.sz then assert false else f_add (s1,s2) acc |s1::r1,s2::r2 -> if s1.sz = s2.sz then f_rec (f_add (s1,s2) acc) (r1,r2) else begin if s1.sz > s2.sz then let (s11,s12) = st_slice s1 s2.sz in f_rec (f_add (s11,s2) acc) (s12::r1,r2) else let (s21,s22) = st_slice s2 s1.sz in f_rec (f_add (s1,s21) acc) (r1,s22::r2) end in f_rec [] (t,u) let fresh_var = let cpt = ref 0 in fun t -> incr cpt; { var = !cpt ; sorte = t} let fresh_bitv genre size = if size <= 0 then [] else [ { bv = S_Var (fresh_var genre) ; sz = size } ] let cte_vs_other bol st = st , [{bv = S_Cte bol ; sz = st.sz}] let cte_vs_ext bol xt s_xt i j = let a1 = fresh_bitv A i in let a2 = fresh_bitv A (s_xt - 1 - j) in let cte = [ {bv = S_Cte bol ; sz =j - i + 1 } ] in let var = { bv = Other xt ; sz = s_xt } in var, a2@cte@a1 let other_vs_other st1 st2 = let c = fresh_bitv C st1.sz in [ (st1,c) ; (st2,c) ] let other_vs_ext st xt s_xt i j = let c = fresh_bitv C st.sz in let a1 = fresh_bitv A i in let a2 = fresh_bitv A (s_xt - 1 - j) in let extr = { bv = Other xt ; sz = s_xt } in [ (st,c) ; (extr,a2 @ c @ a1) ] let ext1_vs_ext2 (id,s,i,j) (id',s',i',j') = (* id != id' *) let c = fresh_bitv (C) (j - i + 1) in let a1 = fresh_bitv A i in let a1' = fresh_bitv A i' in let a2 = fresh_bitv A (s - 1 - j) in let a2' = fresh_bitv A (s' - 1 - j') in let x_v = { sz = s ; bv = Other id } in let y_v = { sz = s' ; bv = Other id' } in [ (x_v , a2 @ c @ a1) ; (y_v , a2' @ c @ a1') ] let ext_vs_ext xt siz (i1,i2) tai = let overl = i1 + tai -i2 in if overl <= 0 then begin let a1 = fresh_bitv A i1 in let a2 = fresh_bitv A (-overl) in let a3 = fresh_bitv A (siz - tai - i2) in let b = fresh_bitv B tai in ({ bv = Other xt ; sz = siz } , a3 @ b @ a2 @ b @ a1) end else begin let b_box = i2 + tai - i1 in let nn_overl = tai - overl in(* =i2-i1 >0 sinon egalite sytaxique*) let sz_b1 = b_box mod nn_overl in let a1 = fresh_bitv A i1 in let a3 = fresh_bitv A (siz - tai - i2) in let b1 = fresh_bitv B sz_b1 in let b2 = fresh_bitv B (nn_overl - sz_b1 )in let acc = ref b1 in let cpt = ref nn_overl in while !cpt <= b_box do acc := b1 @ b2 @(!acc); cpt := !cpt + nn_overl done; ({ bv = Other xt ; sz = siz } , a3 @ (!acc) @ a1) end let sys_solve sys = let c_solve (st1,st2) = match st1.bv,st2.bv with |Cte _, Cte _ -> raise Exception.Unsolvable (* forcement un 1 et un 0 *) |Cte b, Other (Var _) -> [cte_vs_other b st2] |Other (Var _), Cte b -> [cte_vs_other b st1] |Cte b, Other (Alien t) -> [cte_vs_other b st2] |Other (Alien t), Cte b -> [cte_vs_other b st1] |Cte b, Ext(xt,s_xt,i,j) -> [cte_vs_ext b xt s_xt i j] |Ext(xt,s_xt,i,j), Cte b -> [cte_vs_ext b xt s_xt i j] |Other _, Other _ -> other_vs_other st1 st2 |Other _, Ext(xt,s_xt,i,j) -> other_vs_ext st1 xt s_xt i j |Ext(xt,s_xt,i,j), Other _ -> other_vs_ext st2 xt s_xt i j |Ext(id,s,i,j), Ext(id',s',i',j') -> if id <> id' then ext1_vs_ext2 (id,s,i,j) (id',s',i',j') else[ext_vs_ext id s (if i [(t,[cnf])] |(t',cnf')::r -> if t = t' then (t',cnf::cnf')::r else (t',cnf')::(add r (t,cnf)) in List.fold_left add [] l let rec slicing_pattern s_l = let rec f_aux l1 l2 = match (l1,l2) with |[],[] -> [] |a::r1,b::r2 when a = b -> a::(f_aux r1 r2) |a::r1,b::r2 -> if a < b then a::(f_aux r1 ((b-a)::r2)) else b::(f_aux ((a-b)::r1) r2) |_ -> assert false in List.fold_left f_aux (List.hd s_l)(List.tl s_l) let slice_var var s1 = let s2 = var.sz - s1 in match var.bv with |S_Cte _ -> {var with sz = s1},{var with sz = s2},None |S_Var v -> let (fs,sn,tr) = match v.sorte with |A -> (fresh_var A), (fresh_var A), A |B -> (fresh_var B), (fresh_var B), B |C -> (fresh_var C), (fresh_var C), C in {bv = S_Var fs; sz = s1},{bv = S_Var sn; sz = s2},Some tr let rec slice_composition eq pat (ac_eq,c_sub) = match (eq,pat) with |[],[] -> (ac_eq,c_sub) |st::_,n::_ when st.sz < n -> assert false |st::comp,n::pt -> if st.sz = n then slice_composition comp pt (st::ac_eq , c_sub) else let (st_n,res,flag) = slice_var st n in begin match flag with |Some B -> let comp' = List.fold_right (fun s_t acc -> if s_t <> st then s_t::acc else st_n::res::acc )comp [] in slice_composition (res::comp') pt (st_n::ac_eq,c_sub) |Some C -> let ac' = (st_n::ac_eq,(st,(st_n,res))::c_sub) in slice_composition (res::comp) pt ac' | _ -> slice_composition (res::comp) pt (st_n::ac_eq,c_sub) end | _ -> assert false let uniforme_slice vls = let pat = slicing_pattern(List.map (List.map(fun bv ->bv.sz))vls) in let rec f_aux acc subs l_vs = match l_vs with |[] -> acc,subs |eq::eqs -> let (eq',c_subs) = slice_composition eq pat ([],[]) in f_aux (List.rev eq'::acc) (c_subs@subs) eqs in f_aux [] [] vls let rec apply_subs subs sys = let rec f_aux = function |[] -> assert false |v::r -> try let (v1,v2) = List.assoc v subs in v1::v2::(f_aux r) with _ -> v::(f_aux r) in List.map (fun (t,vls) ->(t,List.map f_aux vls))sys let equations_slice parts = let rec slice_rec bw = function |[] -> bw |(t,vls)::r -> let (vls',subs) = uniforme_slice vls in if subs =[] then slice_rec ((t,vls')::bw) r else begin let _bw = apply_subs subs bw in let _fw = apply_subs subs r in if _bw = bw then slice_rec ((t,vls')::bw) _fw else slice_rec [] (bw@((t,vls'):: _fw)) end in slice_rec [] parts let rec union_sets sets = let included e1 e2 = try ST_Set.iter (fun at -> if ST_Set.mem at e2 then raise Exit)e1; false with Exit -> true in match sets with |[] -> [] |st::tl -> let (ok,ko) = List.partition (included st) tl in if ok = [] then st::union_sets tl else union_sets ((List.fold_left ST_Set.union st ok)::ko) let rec init_sets vals = let acc = List.map (fun at -> ST_Set.singleton at) (List.hd vals) in let tl = (List.tl vals) in let f_aux = List.map2 (fun ac_e e -> ST_Set.add e ac_e) in List.fold_left f_aux acc tl let equalities_propagation eqs_slic = let init_sets = List.map (fun (t,vls) -> init_sets vls) eqs_slic in let init_sets = List.flatten init_sets in List.map (fun set -> let st1 = ST_Set.min_elt set and st2 = ST_Set.max_elt set in match st1.bv , st2.bv with |S_Cte false, S_Cte true -> raise Exception.Unsolvable |S_Cte false , _ -> st1,set |_ , _ -> st2,set ) (union_sets init_sets) let build_solution unif_slic sets = let get_rep var = fst(List.find ( fun(rep,set)->ST_Set.mem var set ) sets) in let to_external_ast v = {sz = v.sz; bv = match v.bv with |S_Cte b -> Cte b |S_Var _ -> begin match (get_rep v).bv with |S_Cte b -> Cte b |S_Var tv -> Other (Var tv) end }in let rec cnf_max l = match l with |[] -> [] |[elt]-> [elt] |a::b::r -> begin match a.bv,b.bv with |Cte bol,Cte bol' when bol = bol' -> cnf_max ({ b with sz = a.sz + b.sz }::r) | _,Cte _ -> a::(cnf_max (b::r)) | _ -> a::b::(cnf_max r) end in List.map (fun (t,vls) -> t,cnf_max (List.map to_external_ast (List.hd vls)) )unif_slic let solve u v = if u = v then raise Valid else begin let varsU = get_vars u in let varsV = get_vars v in if varsU = [] && varsV = [] then raise Exception.Unsolvable else begin let st_sys = slice u v in let sys_sols = sys_solve st_sys in let parts = partition sys_sols in let unif_slic = equations_slice parts in let eq_pr = equalities_propagation unif_slic in let sol = build_solution unif_slic eq_pr in if Options.debug_bitv () then begin Debug.print_sliced_sys err st_sys; Debug.print_c_solve_res err sys_sols; Debug.print_partition_res err parts; Debug.print_partition_res err unif_slic; Debug.print_final_solution err sol; end; sol end end end let compare_mine b1 b2 = let rec comp l1 l2 = match l1,l2 with [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 | st1::l1 , st2::l2 -> let c = compare_simple_term st1 st2 in if c<>0 then c else comp l1 l2 in comp b1 b2 let compare x y = compare (embed x) (embed y) (* should use hashed compare to be faster, not structural comparison *) let equal bv1 bv2 = compare_mine bv1 bv2 = 0 let hash_xterm = function | Var {var = i; sorte = A} -> 11 * i | Var {var = i; sorte = B} -> 17 * i | Var {var = i; sorte = C} -> 19 * i | Alien r -> 23 * X.hash r let hash_simple_term_aux = function | Cte b -> 11 * Hashtbl.hash b | Other x -> 17 * hash_xterm x | Ext (x, a, b, c) -> hash_xterm x + 19 * (a + b + c) let hash l = List.fold_left (fun acc {bv=r; sz=sz} -> acc + 19 * (sz + hash_simple_term_aux r) ) 19 l let leaves bitv = List.fold_left (fun acc x -> match x.bv with | Cte _ -> acc | Ext( Var v,sz,_,_) -> (X.embed [{bv=Other (Var v) ; sz = sz }])::acc | Other (Var _) -> (X.embed [x])::acc | Other (Alien t) | Ext(Alien t,_,_,_) -> (X.leaves t)@acc ) [] bitv let is_mine = function [{bv = Other (Alien r)}] -> r | bv -> X.embed bv let print = Debug.print_C_ast let make t = let r, ctx = Canonizer.make t in is_mine r, ctx let color _ = assert false let type_info bv = let sz = List.fold_left (fun acc bv -> bv.sz + acc) 0 bv in Ty.Tbitv sz let to_i_ast biv = let f_aux st = {sz = st.sz; bv = match st.bv with | Cte b -> Canonizer.I_Cte b | Other tt -> Canonizer.I_Other tt | Ext(tt,siz,i,j) -> let tt' = { sz = siz ; bv = Canonizer.I_Other tt } in Canonizer.I_Ext(tt',i,j) } in List.fold_left (fun acc st -> let tmp = f_aux st in { bv = Canonizer.I_Comp(acc,tmp) ; sz = acc.sz + tmp.sz } ) (f_aux (List.hd biv)) (List.tl biv) let size_of r = match X.type_info r with Ty.Tbitv i -> i | _ -> Format.eprintf "ici=%a@." X.print r; assert false let extract r ty = match X.extract r with Some (u::_ as bv) -> to_i_ast bv | None -> {bv = Canonizer.I_Other (Alien r); sz = ty} | Some [] -> assert false let extract_xterm r = match X.extract r with Some ([{bv=Other(Var _ as x)}]) -> x | None -> Alien r | _ -> assert false let var_or_term x = match x.bv with Other (Var _) -> X.embed [x] | Other (Alien r) -> r | _ -> assert false (* ne resout pas quand c'est deja resolu *) let solve_bis u t = if Options.debug_bitv () then eprintf "[Bitv] solve %a = %a@." X.print u X.print t; match X.extract u , X.extract t with | None , None -> if X.str_cmp u t > 0 then [u,t] else [t,u] | None , Some _ -> [u , t] | Some _ , None -> [t , u] | Some u , Some t -> try List.map (fun (p,v) -> var_or_term p,is_mine v) (Solver.solve u t) with Solver.Valid -> [] let rec subst_rec x subs biv = match biv.bv , extract_xterm x with | Canonizer.I_Cte _ , _ -> biv | Canonizer.I_Other (Var y) , Var z when y=z -> extract subs biv.sz | Canonizer.I_Other (Var _) , _ -> biv | Canonizer.I_Other (Alien tt) , _ -> if X.equal x tt then extract subs biv.sz else extract (X.subst x subs tt) biv.sz | Canonizer.I_Ext (t,i,j) , _ -> { biv with bv = Canonizer.I_Ext(subst_rec x subs t,i,j) } | Canonizer.I_Comp (u,v) , _ -> { biv with bv = Canonizer.I_Comp(subst_rec x subs u ,subst_rec x subs v)} let subst x subs biv = if Options.debug_bitv () then eprintf "[Bitv] subst %a |-> %a in %a@." X.print x X.print subs print biv; if biv = [] then is_mine biv else let r = Canonizer.sigma (subst_rec x subs (to_i_ast biv)) in is_mine r (* module M = Map.Make (struct type t = X.r let compare = X.compare end) module Map = Map.Make (struct type t = (X.r simple_term) list let compare = compare_mine end) module Set = Set.Make ( struct type t = (X.r simple_term) list let compare = compare_mine end) *) let fully_interpreted sb = true let term_extract _ = None, false let abstract_selectors v acc = is_mine v, acc let solve r1 r2 pb = {pb with sbt = List.rev_append (solve_bis r1 r2) pb.sbt} let assign_value _ __ = failwith "[Bitv.assign_value] not implemented for theory Bitv" let choose_adequate_model t l = assert false end module Relation (X : ALIEN) (Uf : Uf.S) = struct type r = X.r type t = unit type uf = Uf.t exception Inconsistent let empty _ = () let assume _ _ _ = (), { assume = []; remove = []} let query _ _ _ = Sig.No let case_split env _ ~for_model = [] let add env _ _ _ = env let print_model _ _ _ = () let new_terms env = T.Set.empty end alt-ergo-1.30/src/theories/polynome.mli0000644000175000001440000000647513014515065016505 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Numbers.Z open Numbers.Q exception Not_a_num exception Maybe_zero module type S = sig include Sig.X val mult : r -> r -> r end module type T = sig type r type t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val create : (Numbers.Q.t * r) list -> Numbers.Q.t -> Ty.t-> t val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val mult_const : Numbers.Q.t -> t -> t val add_const : Numbers.Q.t -> t -> t val div : t -> t -> t * bool val modulo : t -> t -> t val is_const : t -> Numbers.Q.t option val is_empty : t -> bool val find : r -> t -> Numbers.Q.t val choose : t -> Numbers.Q.t * r val subst : r -> t -> t -> t val remove : r -> t -> t val to_list : t -> (Numbers.Q.t * r) list * Numbers.Q.t val leaves : t -> r list val print : Format.formatter -> t -> unit val type_info : t -> Ty.t val is_monomial : t -> (Numbers.Q.t * r * Numbers.Q.t) option (* PPMC des denominateurs des coefficients excepte la constante *) val ppmc_denominators : t -> Numbers.Q.t (* PGCD des numerateurs des coefficients excepte la constante *) val pgcd_numerators : t -> Numbers.Q.t (* retourne un polynome sans constante et sa constante et la constante multiplicative: normal_form p = (p',c,d) <=> p = (p' + c) * d *) val normal_form : t -> t * Numbers.Q.t * Numbers.Q.t (* comme normal_form mais le signe est aussi normalise *) val normal_form_pos : t -> t * Numbers.Q.t * Numbers.Q.t val abstract_selectors : t -> (r * r) list -> t * (r * r) list val separate_constant : t -> t * Numbers.Q.t end module type EXTENDED_Polynome = sig include T val extract : r -> t option val embed : t -> r end module Make (X : S) : T with type r = X.r alt-ergo-1.30/src/theories/polynome.ml0000644000175000001440000002377413014515065016335 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options module Z = Numbers.Z module Q = Numbers.Q exception Not_a_num exception Maybe_zero module type S = sig include Sig.X val mult : r -> r -> r end module type T = sig type r type t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val create : (Q.t * r) list -> Q.t -> Ty.t-> t val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val mult_const : Q.t -> t -> t val add_const : Q.t -> t -> t val div : t -> t -> t * bool val modulo : t -> t -> t val is_const : t -> Q.t option val is_empty : t -> bool val find : r -> t -> Q.t val choose : t -> Q.t * r val subst : r -> t -> t -> t val remove : r -> t -> t val to_list : t -> (Q.t * r) list * Q.t val leaves : t -> r list val print : Format.formatter -> t -> unit val type_info : t -> Ty.t val is_monomial : t -> (Q.t * r * Q.t) option val ppmc_denominators : t -> Q.t val pgcd_numerators : t -> Q.t val normal_form : t -> t * Q.t * Q.t val normal_form_pos : t -> t * Q.t * Q.t val abstract_selectors : t -> (r * r) list -> t * (r * r) list val separate_constant : t -> t * Numbers.Q.t end module type EXTENDED_Polynome = sig include T val extract : r -> t option val embed : t -> r end module Make (X : S) = struct type r = X.r module M : Map.S with type key = r = Map.Make( struct type t = r (*sorted in decreasing order to comply with AC(X) order requirements*) let compare x y = X.str_cmp y x end) type t = { m : Q.t M.t; c : Q.t; ty : Ty.t } let map_to_list m = List.rev (M.fold (fun x a aliens -> (a, x)::aliens) m []) exception Out of int let compare_maps l1 l2 = try List.iter2 (fun (a,x) (b,y) -> let c = X.str_cmp x y in if c <> 0 then raise (Out c); let c = Q.compare a b in if c <> 0 then raise (Out c) )l1 l2; 0 with | Out c -> c | Invalid_argument s -> assert (String.compare s "List.iter2" = 0); List.length l1 - List.length l2 let compare p1 p2 = let c = Ty.compare p1.ty p2.ty in if c <> 0 then c else match M.is_empty p1.m, M.is_empty p2.m with | true , false -> -1 | false, true -> 1 | true , true -> Q.compare p1.c p2.c | false, false -> let c = compare_maps (map_to_list p1.m) (map_to_list p2.m) in if c = 0 then Q.compare p1.c p2.c else c let equal {m=m1; c=c1} {m=m2; c=c2} = Q.equal c1 c2 && M.equal Q.equal m1 m2 let hash p = let h = M.fold (fun k v acc -> 23 * acc + (X.hash k) * Q.hash v )p.m (19 * Q.hash p.c + 17 * Ty.hash p.ty) in abs h (*BISECT-IGNORE-BEGIN*) module Debug = struct let pprint fmt p = let zero = ref true in M.iter (fun x n -> let s, n, op = if Q.equal n Q.one then (if !zero then "" else "+"), "", "" else if Q.equal n Q.m_one then "-", "", "" else if Q.sign n > 0 then (if !zero then "" else "+"), Q.to_string n, "*" else "-", Q.to_string (Q.minus n), "*" in zero := false; fprintf fmt "%s%s%s%a" s n op X.print x ) p.m; let s, n = if Q.sign p.c > 0 then (if !zero then "" else "+"), Q.to_string p.c else if Q.sign p.c < 0 then "-", Q.to_string (Q.minus p.c) else (if !zero then "","0" else "","") in fprintf fmt "%s%s" s n let print fmt p = if Options.term_like_pp () then pprint fmt p else begin M.iter (fun t n -> fprintf fmt "%s*%a " (Q.to_string n) X.print t) p.m; fprintf fmt "%s" (Q.to_string p.c); fprintf fmt " [%a]" Ty.print p.ty end end (*BISECT-IGNORE-END*) let print = Debug.print let is_const p = if M.is_empty p.m then Some p.c else None let find x m = try M.find x m with Not_found -> Q.zero let create l c ty = let m = List.fold_left (fun m (n, x) -> let n' = Q.add n (find x m) in if Q.sign n' = 0 then M.remove x m else M.add x n' m) M.empty l in { m = m; c = c; ty = ty } let add p1 p2 = Options.tool_req 4 "TR-Arith-Poly plus"; let m = M.fold (fun x a m -> let a' = Q.add (find x m) a in if Q.sign a' = 0 then M.remove x m else M.add x a' m) p2.m p1.m in { m = m; c = Q.add p1.c p2.c; ty = p1.ty } let mult_const n p = if Q.sign n = 0 then { m = M.empty; c = Q.zero; ty = p.ty } else { p with m = M.map (Q.mult n) p.m; c = Q.mult n p.c } let add_const n p = {p with c = Q.add p.c n} let mult_monome a x p = let ax = { m = M.add x a M.empty; c = Q.zero; ty = p.ty} in let acx = mult_const p.c ax in let m = M.fold (fun xi ai m -> M.add (X.mult x xi) (Q.mult a ai) m) p.m acx.m in { acx with m = m} let mult p1 p2 = Options.tool_req 4 "TR-Arith-Poly mult"; let p = mult_const p1.c p2 in M.fold (fun x a p -> add (mult_monome a x p2) p) p1.m p let sub p1 p2 = Options.tool_req 4 "TR-Arith-Poly moins"; let m = M.fold (fun x a m -> let a' = Q.sub (find x m) a in if Q.sign a' = 0 then M.remove x m else M.add x a' m) p2.m p1.m in { m = m; c = Q.sub p1.c p2.c; ty = p1.ty } let euc_mod_num c1 c2 = let c = Q.modulo c1 c2 in if Q.sign c < 0 then Q.add c (Q.abs c2) else c let euc_div_num c1 c2 = Q.div (Q.sub c1 (euc_mod_num c1 c2)) c2 let div p1 p2 = Options.tool_req 4 "TR-Arith-Poly div"; if not (M.is_empty p2.m) then raise Maybe_zero; if Q.sign p2.c = 0 then raise Division_by_zero; let p = mult_const (Q.div Q.one p2.c) p1 in match M.is_empty p.m, p.ty with | _ , Ty.Treal -> p, false | true, Ty.Tint -> {p with c = euc_div_num p1.c p2.c}, false | false, Ty.Tint -> p, true (* XXX *) | _ -> assert false let modulo p1 p2 = Options.tool_req 4 "TR-Arith-Poly mod"; if not (M.is_empty p2.m) then raise Maybe_zero; if Q.sign p2.c = 0 then raise Division_by_zero; if not (M.is_empty p1.m) then raise Not_a_num; { p1 with c = euc_mod_num p1.c p2.c } let find x p = M.find x p.m let is_empty p = M.is_empty p.m let choose p = let tn= ref None in (*version I : prend le premier element de la table*) (try M.iter (fun x a -> tn := Some (a, x); raise Exit) p.m with Exit -> ()); (*version II : prend le dernier element de la table i.e. le plus grand M.iter (fun x a -> tn := Some (a, x)) p.m;*) match !tn with Some p -> p | _ -> raise Not_found let subst x p1 p2 = try let a = M.find x p2.m in add (mult_const a p1) { p2 with m = M.remove x p2.m} with Not_found -> p2 let remove x p = { p with m = M.remove x p.m } let to_list p = map_to_list p.m , p.c module SX = Set.Make(struct type t = r let compare = X.hash_cmp end) let xs_of_list sx l = List.fold_left (fun s x -> SX.add x s) sx l let leaves p = let s = M.fold (fun a _ s -> xs_of_list s (X.leaves a)) p.m SX.empty in SX.elements s let type_info p = p.ty let is_monomial p = try M.fold (fun x a r -> match r with | None -> Some (a, x, p.c) | _ -> raise Exit) p.m None with Exit -> None let ppmc_denominators {m=m} = let res = M.fold (fun k c acc -> Z.my_lcm (Q.den c) acc) m Z.one in Q.abs (Q.from_z res) let pgcd_numerators {m=m} = let res = M.fold (fun k c acc -> Z.my_gcd (Q.num c) acc) m Z.zero in Q.abs (Q.from_z res) let normal_form ({ m = m; c = c } as p) = if M.is_empty m then { p with c = Q.zero }, p.c, Q.one else let ppcm = ppmc_denominators p in let pgcd = pgcd_numerators p in let p = mult_const (Q.div ppcm pgcd) p in { p with c = Q.zero }, p.c, (Q.div pgcd ppcm) let normal_form_pos p = let p, c, d = normal_form p in try let a,x = choose p in if Q.sign a > 0 then p, c, d else mult_const Q.m_one p, Q.minus c, Q.minus d with Not_found -> p, c, d let abstract_selectors p acc = let mp, acc = M.fold (fun r i (mp, acc) -> let r, acc = X.abstract_selectors r acc in let mp = try let j = M.find r mp in let k = Q.add i j in if Q.sign k = 0 then M.remove r mp else M.add r k mp with Not_found -> M.add r i mp in mp, acc )p.m (M.empty, acc) in {p with m=mp}, acc let separate_constant t = { t with c = Q.zero}, t.c end alt-ergo-1.30/src/theories/arith.ml0000644000175000001440000005076613014515065015603 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig module A = Literal module Sy = Symbols module T = Term module Z = Numbers.Z module Q = Numbers.Q let ale = Hstring.make "<=" let alt = Hstring.make "<" let is_mult h = Sy.equal (Sy.Op Sy.Mult) h let mod_symb = Sy.name "@mod" module Type (X:Sig.X) : Polynome.T with type r = X.r = struct include Polynome.Make(struct include X module Ac = Ac.Make(X) let mult v1 v2 = X.ac_embed { distribute = true; h = Sy.Op Sy.Mult; t = X.type_info v1; l = let l2 = match X.ac_extract v1 with | Some {h=h; l=l} when Sy.equal h (Sy.Op Sy.Mult) -> l | _ -> [v1, 1] in Ac.add (Sy.Op Sy.Mult) (v2,1) l2 } end) end module Shostak (X : Sig.X) (P : Polynome.EXTENDED_Polynome with type r = X.r) = struct type t = P.t type r = P.r module Ac = Ac.Make(X) let name = "arith" (*BISECT-IGNORE-BEGIN*) module Debug = struct let solve_aux r1 r2 = if debug_arith () then fprintf fmt "[arith:solve-aux] we solve %a=%a@." X.print r1 X.print r2 let solve_one r1 r2 sbs = if debug_arith () then begin fprintf fmt "[arith:solve-one] solving %a = %a yields:@." X.print r1 X.print r2; let c = ref 0 in List.iter (fun (p,v) -> incr c; fprintf fmt " %d) %a |-> %a@." !c X.print p X.print v) sbs end end (*BISECT-IGNORE-END*) let is_mine_symb = function | Sy.Int _ | Sy.Real _ | Sy.Op (Sy.Plus | Sy.Minus | Sy.Mult | Sy.Div | Sy.Modulo) -> true | _ -> false let empty_polynome ty = P.create [] Q.zero ty let is_mine p = match P.is_monomial p with | Some (a,x,b) when Q.equal a Q.one && Q.sign b = 0 -> x | _ -> P.embed p let embed r = match P.extract r with | Some p -> p | _ -> P.create [Q.one, r] Q.zero (X.type_info r) (* t1 % t2 = md <-> c1. 0 <= md ; c2. md < t2 ; c3. exists k. t1 = t2 * k + t ; c4. t2 <> 0 (already checked) *) let mk_modulo md t1 t2 p2 ctx = let zero = T.int "0" in let c1 = A.LT.mk_builtin true ale [zero; md] in let c2 = match P.is_const p2 with | Some n2 -> let an2 = Q.abs n2 in assert (Q.is_int an2); let t2 = T.int (Q.to_string an2) in A.LT.mk_builtin true alt [md; t2] | None -> A.LT.mk_builtin true alt [md; t2] in let k = T.fresh_name Ty.Tint in let t3 = T.make (Sy.Op Sy.Mult) [t2;k] Ty.Tint in let t3 = T.make (Sy.Op Sy.Plus) [t3;md] Ty.Tint in let c3 = A.LT.mk_eq t1 t3 in c3 :: c2 :: c1 :: ctx let mk_euc_division p p2 t1 t2 ctx = match P.to_list p2 with | [], coef_p2 -> let md = T.make (Sy.Op Sy.Modulo) [t1;t2] Ty.Tint in let r, ctx' = X.make md in let rp = P.mult_const (Q.div Q.one coef_p2) (embed r) in P.sub p rp, ctx' @ ctx | _ -> assert false let rec mke coef p t ctx = let {T.f = sb ; xs = xs; ty = ty} = T.view t in match sb, xs with | (Sy.Int n | Sy.Real n) , _ -> let c = Q.mult coef (Q.from_string (Hstring.view n)) in P.add_const c p, ctx | Sy.Op Sy.Mult, [t1;t2] -> let p1, ctx = mke coef (empty_polynome ty) t1 ctx in let p2, ctx = mke Q.one (empty_polynome ty) t2 ctx in if Options.no_NLA() && P.is_const p1 == None && P.is_const p2 == None then (* becomes uninterpreted *) let tau = Term.make (Sy.name ~kind:Sy.Ac "@*") [t1; t2] ty in let xtau, ctx' = X.make tau in P.add p (P.create [coef, xtau] Q.zero ty), List.rev_append ctx' ctx else P.add p (P.mult p1 p2), ctx | Sy.Op Sy.Div, [t1;t2] -> let p1, ctx = mke Q.one (empty_polynome ty) t1 ctx in let p2, ctx = mke Q.one (empty_polynome ty) t2 ctx in if Options.no_NLA() && (P.is_const p2 == None || (ty == Ty.Tint && P.is_const p1 == None)) then (* becomes uninterpreted *) let tau = Term.make (Sy.name "@/") [t1; t2] ty in let xtau, ctx' = X.make tau in P.add p (P.create [coef, xtau] Q.zero ty), List.rev_append ctx' ctx else let p3, ctx = try let p, approx = P.div p1 p2 in if approx then mk_euc_division p p2 t1 t2 ctx else p, ctx with Division_by_zero | Polynome.Maybe_zero -> P.create [Q.one, X.term_embed t] Q.zero ty, ctx in P.add p (P.mult_const coef p3), ctx | Sy.Op Sy.Plus , [t1;t2] -> let p2, ctx = mke coef p t2 ctx in mke coef p2 t1 ctx | Sy.Op Sy.Minus , [t1;t2] -> let p2, ctx = mke (Q.minus coef) p t2 ctx in mke coef p2 t1 ctx | Sy.Op Sy.Modulo , [t1;t2] -> let p1, ctx = mke Q.one (empty_polynome ty) t1 ctx in let p2, ctx = mke Q.one (empty_polynome ty) t2 ctx in if Options.no_NLA() && (P.is_const p1 == None || P.is_const p2 == None) then (* becomes uninterpreted *) let tau = Term.make (Sy.name "@%") [t1; t2] ty in let xtau, ctx' = X.make tau in P.add p (P.create [coef, xtau] Q.zero ty), List.rev_append ctx' ctx else let p3, ctx = try P.modulo p1 p2, ctx with e -> let t = T.make mod_symb [t1; t2] Ty.Tint in let ctx = match e with | Division_by_zero | Polynome.Maybe_zero -> ctx | Polynome.Not_a_num -> mk_modulo t t1 t2 p2 ctx | _ -> assert false in P.create [Q.one, X.term_embed t] Q.zero ty, ctx in P.add p (P.mult_const coef p3), ctx | _ -> let a, ctx' = X.make t in let ctx = ctx' @ ctx in match P.extract a with | Some p' -> P.add p (P.mult_const coef p'), ctx | _ -> P.add p (P.create [coef, a] Q.zero ty), ctx let make t = Options.tool_req 4 "TR-Arith-Make"; let {T.ty = ty} = T.view t in let p, ctx = mke Q.one (empty_polynome ty) t [] in is_mine p, ctx let rec expand p n acc = assert (n >=0); if n = 0 then acc else expand p (n-1) (p::acc) let unsafe_ac_to_arith {h=sy; l=rl; t=ty} = let mlt = List.fold_left (fun l (r,n) -> expand (embed r)n l) [] rl in List.fold_left P.mult (P.create [] Q.one ty) mlt let rec number_of_vars l = List.fold_left (fun acc (r, n) -> acc + n * nb_vars_in_alien r) 0 l and nb_vars_in_alien r = match P.extract r with | Some p -> let l, _ = P.to_list p in List.fold_left (fun acc (a, x) -> max acc (nb_vars_in_alien x)) 0 l | None -> begin match X.ac_extract r with | Some ac when is_mult ac.h -> number_of_vars ac.l | _ -> 1 end let max_list_ = function | [] -> 0 | [ _, x ] -> nb_vars_in_alien x | (_, x) :: l -> let acc = nb_vars_in_alien x in List.fold_left (fun acc (_, x) -> max acc (nb_vars_in_alien x)) acc l let contains_a_fresh_alien xp = List.exists (fun x -> match X.term_extract x with | Some t, _ -> Term.is_fresh t | _ -> false ) (X.leaves xp) let has_ac p kind = List.exists (fun (_, x) -> match X.ac_extract x with Some ac -> kind ac | _ -> false) (fst (P.to_list p)) let color ac = match ac.l with | [(r, 1)] -> assert false | _ -> let p = unsafe_ac_to_arith ac in if not ac.distribute then if has_ac p (fun ac -> is_mult ac.h) then X.ac_embed ac else is_mine p else let xp = is_mine p in if contains_a_fresh_alien xp then let l, _ = P.to_list p in let mx = max_list_ l in if mx = 0 || mx = 1 || number_of_vars ac.l > mx then is_mine p else X.ac_embed ac else xp let type_info p = P.type_info p module SX = Set.Make(struct type t = r let compare = X.hash_cmp end) let leaves p = P.leaves p let subst x t p = let p = P.subst x (embed t) p in let ty = P.type_info p in let l, c = P.to_list p in let p = List.fold_left (fun p (ai, xi) -> let xi' = X.subst x t xi in let p' = match P.extract xi' with | Some p' -> P.mult_const ai p' | _ -> P.create [ai, xi'] Q.zero ty in P.add p p') (P.create [] c ty) l in is_mine p let compare_mine = P.compare let compare x y = P.compare (embed x) (embed y) let equal p1 p2 = P.equal p1 p2 let hash = P.hash (* symmetric modulo p 131 *) let mod_sym a b = let m = Q.modulo a b in let m = if Q.sign m < 0 then if Q.compare m (Q.minus b) >= 0 then Q.add m b else assert false else if Q.compare m b <= 0 then m else assert false in if Q.compare m (Q.div b (Q.from_int 2)) < 0 then m else Q.sub m b let map_monomes f l ax = List.fold_left (fun acc (a,x) -> let a = f a in if Q.sign a = 0 then acc else (a, x) :: acc) [ax] l let apply_subst sb v = is_mine (List.fold_left (fun v (x, p) -> embed (subst x p v)) v sb) (* substituer toutes variables plus grandes que x *) let subst_bigger x l = List.fold_left (fun (l, sb) (b, y) -> if X.ac_extract y != None && X.str_cmp y x > 0 then let k = X.term_embed (T.fresh_name Ty.Tint) in (b, k) :: l, (y, embed k)::sb else (b, y) :: l, sb) ([], []) l let is_mine_p = List.map (fun (x,p) -> x, is_mine p) let extract_min = function | [] -> assert false | [c] -> c, [] | (a, x) :: s -> List.fold_left (fun ((a, x), l) (b, y) -> if Q.compare (Q.abs a) (Q.abs b) <= 0 then (a, x), ((b, y) :: l) else (b, y), ((a, x):: l)) ((a, x),[]) s (* Decision Procedures. Page 131 *) let rec omega l b = (* 1. choix d'une variable donc le |coef| est minimal *) let (a, x), l = extract_min l in (* 2. substituer les aliens plus grand que x pour assurer l'invariant sur l'ordre AC *) let l, sbs = subst_bigger x l in let p = P.create l b Ty.Tint in assert (Q.sign a <> 0); if Q.equal a Q.one then (* 3.1. si a = 1 alors on a une substitution entiere pour x *) let p = P.mult_const Q.m_one p in (x, is_mine p) :: (is_mine_p sbs) else if Q.equal a Q.m_one then (* 3.2. si a = -1 alors on a une subst entiere pour x*) (x,is_mine p) :: (is_mine_p sbs) else (* 4. sinon, (|a| <> 1) et a <> 0 *) (* 4.1. on rend le coef a positif s'il ne l'est pas deja *) let a, l, b = if Q.sign a < 0 then (Q.minus a, List.map (fun (a,x) -> Q.minus a,x) l, (Q.minus b)) else (a, l, b) in (* 4.2. on reduit le systeme *) omega_sigma sbs a x l b and omega_sigma sbs a x l b = (* 1. on definie m qui vaut a + 1 *) let m = Q.add a Q.one in (* 2. on introduit une variable fraiche *) let sigma = X.term_embed (T.fresh_name Ty.Tint) in (* 3. l'application de la formule (5.63) nous donne la valeur du pivot x*) let mm_sigma = (Q.minus m, sigma) in let l_mod = map_monomes (fun a -> mod_sym a m) l mm_sigma in (* 3.1. Attention au signe de b : on le passe a droite avant de faire mod_sym, d'ou Q.minus *) let b_mod = Q.minus (mod_sym (Q.minus b) m) in let p = P.create l_mod b_mod Ty.Tint in let sbs = (x, p) :: sbs in (* 4. on substitue x par sa valeur dans l'equation de depart. Voir la formule (5.64) *) let p' = P.add (P.mult_const a p) (P.create l b Ty.Tint) in (* 5. on resoud sur l'equation simplifiee *) let sbs2 = solve_int p' in (* 6. on normalise sbs par sbs2 *) let sbs = List.map (fun (x, v) -> x, apply_subst sbs2 v) sbs in (* 7. on supprime les liaisons inutiles de sbs2 et on merge avec sbs *) let sbs2 = List.filter (fun (y, _) -> not (X.equal y sigma)) sbs2 in List.rev_append sbs sbs2 and solve_int p = if P.is_empty p then raise Not_found; let pgcd = P.pgcd_numerators p in let ppmc = P.ppmc_denominators p in let p = P.mult_const (Q.div ppmc pgcd) p in let l, b = P.to_list p in if not (Q.is_int b) then raise Exception.Unsolvable; omega l b let is_null p = if Q.sign (snd (P.separate_constant p)) <> 0 then raise Exception.Unsolvable; [] let solve_int p = try solve_int p with Not_found -> is_null p let solve_real p = try let a, x = P.choose p in let p = P.mult_const (Q.div Q.m_one a) (P.remove x p) in [x, is_mine p] with Not_found -> is_null p let unsafe_ac_to_arith {h=sy; l=rl; t=ty} = let mlt = List.fold_left (fun l (r, n) -> expand (embed r) n l) [] rl in List.fold_left P.mult (P.create [] Q.one ty) mlt let polynome_distribution p unsafe_mode = let l, c = P.to_list p in let ty = P.type_info p in let pp = List.fold_left (fun p (coef, x) -> match X.ac_extract x with | Some ac when is_mult ac.h -> P.add p (P.mult_const coef (unsafe_ac_to_arith ac)) | _ -> P.add p (P.create [coef,x] Q.zero ty) ) (P.create [] c ty) l in if not unsafe_mode && has_ac pp (fun ac -> is_mult ac.h) then p else pp let solve_aux r1 r2 unsafe_mode = Options.tool_req 4 "TR-Arith-Solve"; Debug.solve_aux r1 r2; let p = P.sub (embed r1) (embed r2) in let pp = polynome_distribution p unsafe_mode in let ty = P.type_info p in let sbs = if ty == Ty.Treal then solve_real pp else solve_int pp in let sbs = List.fast_sort (fun (a,_) (x,y) -> X.str_cmp x a)sbs in sbs let apply_subst r l = List.fold_left (fun r (p,v) -> X.subst p v r) r l exception Unsafe let check_pivot_safety p nsbs unsafe_mode = let q = apply_subst p nsbs in if X.equal p q then p else match X.ac_extract p with | Some ac when unsafe_mode -> raise Unsafe | Some ac -> X.ac_embed {ac with distribute = false} | None -> assert false (* p is a leaf and not interpreted *) let triangular_down sbs unsafe_mode = List.fold_right (fun (p,v) nsbs -> (check_pivot_safety p nsbs unsafe_mode, apply_subst v nsbs) :: nsbs) sbs [] let is_non_lin pv = match X.ac_extract pv with | Some {Sig.h} -> is_mult h | _ -> false let make_idemp a b sbs lvs unsafe_mode = let sbs = triangular_down sbs unsafe_mode in let sbs = triangular_down (List.rev sbs) unsafe_mode in (*triangular up*) let sbs = List.filter (fun (p,v) -> SX.mem p lvs || is_non_lin p) sbs in assert (not (Options.enable_assertions ()) || X.equal (apply_subst a sbs) (apply_subst b sbs)); List.iter (fun (p, v) -> if not (SX.mem p lvs) then (assert (is_non_lin p); raise Unsafe) )sbs; sbs let solve_one pb r1 r2 lvs unsafe_mode = let sbt = solve_aux r1 r2 unsafe_mode in let sbt = make_idemp r1 r2 sbt lvs unsafe_mode in (*may raise Unsafe*) Debug.solve_one r1 r2 sbt; {pb with sbt = List.rev_append sbt pb.sbt} let solve r1 r2 pb = let lvs = List.fold_right SX.add (X.leaves r1) SX.empty in let lvs = List.fold_right SX.add (X.leaves r2) lvs in try if debug_arith () then fprintf fmt "[arith] Try solving with unsafe mode.@."; solve_one pb r1 r2 lvs true (* true == unsafe mode *) with Unsafe -> try if debug_arith () then fprintf fmt "[arith] Cancel unsafe solving mode. Try safe mode@."; solve_one pb r1 r2 lvs false (* false == safe mode *) with Unsafe -> assert false let make t = if Options.timers() then try Options.exec_timer_start Timers.M_Arith Timers.F_make; let res = make t in Options.exec_timer_pause Timers.M_Arith Timers.F_make; res with e -> Options.exec_timer_pause Timers.M_Arith Timers.F_make; raise e else make t let solve r1 r2 pb = if Options.timers() then try Options.exec_timer_start Timers.M_Arith Timers.F_solve; let res = solve r1 r2 pb in Options.exec_timer_pause Timers.M_Arith Timers.F_solve; res with e -> Options.exec_timer_pause Timers.M_Arith Timers.F_solve; raise e else solve r1 r2 pb let print = P.print let fully_interpreted sb = match sb with | Sy.Op (Sy.Plus | Sy.Minus) -> true | _ -> false let term_extract _ = None, false let abstract_selectors p acc = let p, acc = P.abstract_selectors p acc in is_mine p, acc (* this function is only called when some arithmetic values do not yet appear in IntervalCalculus. Otherwise, the simplex with try to assign a value *) let assign_value = let cpt_int = ref Q.m_one in let cpt_real = ref Q.m_one in let max_constant distincts acc = List.fold_left (fun acc x -> match P.is_const (embed x) with None -> acc | Some c -> Q.max c acc) acc distincts in fun r distincts eq -> if P.is_const (embed r) != None then None else if List.exists (fun (t,x) ->is_mine_symb (Term.view t).Term.f && X.leaves x == []) eq then None else let term_of_cst, cpt = match X.type_info r with | Ty.Tint -> Term.int, cpt_int | Ty.Treal -> Term.real, cpt_real | _ -> assert false in cpt := Q.add Q.one (max_constant distincts !cpt); Some (term_of_cst (Q.to_string !cpt), true) let pprint_const_for_model = let pprint_positive_const c = let num = Q.num c in let den = Q.den c in if Z.is_one den then Z.to_string num else Format.sprintf "(/ %s %s)" (Z.to_string num) (Z.to_string den) in fun r -> match P.is_const (embed r) with | None -> assert false | Some c -> let sg = Q.sign c in if sg = 0 then "0" else if sg > 0 then pprint_positive_const c else Format.sprintf "(- %s)" (pprint_positive_const (Q.abs c)) let choose_adequate_model t r l = if debug_interpretation() then fprintf fmt "[arith] choose_adequate_model for %a@." Term.print t; let l = List.filter (fun (_, r) -> P.is_const (embed r) != None) l in let r = match l with | [] -> (* We do this, because terms of some semantic values created by CS are not created and added to UF *) assert (P.is_const (embed r) != None); r | (_,r)::l -> List.iter (fun (_,x) -> assert (X.equal x r)) l; r in r, pprint_const_for_model r end module Relation = IntervalCalculus.Make alt-ergo-1.30/src/theories/use.ml0000644000175000001440000001006013014515065015247 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format module T = Term module ST = T.Set module SA = Set.Make (struct type t = Literal.LT.t * Explanation.t let compare (s1,_) (s2,_) = Literal.LT.compare s1 s2 end) module type S = sig type t type r val empty : t val find : r -> t -> Term.Set.t * SA.t val add : r -> Term.Set.t * SA.t -> t -> t val mem : r -> t -> bool val print : t -> unit val up_add : t -> Term.t -> r -> r list -> t val congr_add : t -> r list -> Term.Set.t val up_close_up :t -> r -> r -> t val congr_close_up : t -> r -> r list -> Term.Set.t * SA.t end module Make (X : Sig.X) : S with type r = X.r = struct module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) type t = (ST.t * SA.t) MX.t type r = X.r let inter_tpl (x1,y1) (x2,y2) = Options.exec_thread_yield (); ST.inter x1 x2, SA.inter y1 y2 let union_tpl (x1,y1) (x2,y2) = Options.exec_thread_yield (); ST.union x1 x2, SA.union y1 y2 let one, _ = X.make (Term.make (Symbols.name "@bottom") [] Ty.Tint) let leaves r = match X.leaves r with [] -> [one] | l -> l let find k m = try MX.find k m with Not_found -> (ST.empty,SA.empty) let add_term k t mp = let g_t,g_a = find k mp in MX.add k (ST.add t g_t,g_a) mp let up_add g t rt lvs = let g = if MX.mem rt g then g else MX.add rt (ST.empty, SA.empty) g in List.fold_left (fun g x -> add_term x t g) g lvs let congr_add g lvs = match lvs with [] -> ST.empty | x::ls -> List.fold_left (fun acc y -> ST.inter (fst(find y g)) acc) (fst(find x g)) ls let up_close_up g p v = let lvs = leaves v in let g_p = find p g in List.fold_left (fun gg l -> MX.add l (union_tpl g_p (find l g)) gg) g lvs let congr_close_up g p touched = let inter = function [] -> (ST.empty, SA.empty) | rx::l -> List.fold_left (fun acc x ->inter_tpl acc (find x g))(find rx g) l in List.fold_left (fun (st,sa) tch -> union_tpl (st,sa)(inter (leaves tch))) (find p g) touched let print g = if debug_use () then begin let sterms fmt = ST.iter (fprintf fmt "%a " T.print) in let satoms fmt = SA.iter (fun (a,e) -> fprintf fmt "%a %a" Literal.LT.print a Explanation.print e) in fprintf fmt "@{[use]@} gamma :\n"; MX.iter (fun t (st,sa) -> fprintf fmt "%a is used by {%a} and {%a}\n" X.print t sterms st satoms sa ) g end let mem = MX.mem let add = MX.add let empty = MX.empty end alt-ergo-1.30/src/theories/inequalities.mli0000644000175000001440000000704713014515065017333 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module type S = sig module P : Polynome.EXTENDED_Polynome module MP : Map.S with type key = P.t type t = { ple0 : P.t; is_le : bool; dep : (Numbers.Q.t * P.t * bool) Util.MI.t; expl : Explanation.t; age : Numbers.Z.t; } module MINEQS : sig type mp = (t * Numbers.Q.t) MP.t val empty : mp val is_empty : mp -> bool val younger : t -> t -> bool val insert : t -> mp -> mp val ineqs_of : mp -> t list val add_to_map : mp -> t list -> mp val iter : (P.t -> (t * Numbers.Q.t) -> unit) -> mp -> unit val fold : (P.t -> (t * Numbers.Q.t) -> 'a -> 'a) -> mp -> 'a -> 'a end val current_age : unit -> Numbers.Z.t val incr_age : unit -> unit val create_ineq : P.t -> P.t -> bool -> Literal.LT.t option -> Explanation.t -> t val print_inequation : Format.formatter -> t -> unit val fourierMotzkin : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val fmSimplex : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val available : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc end module FM (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P module type Container_SIG = sig module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P end val get_current : unit -> (module Container_SIG) (** returns the current activated 'inequalities reasoner'. The default value is the Fourier-Motzkin module. When the selected reasoner is an external plugin, the first call of this function will attemp to dynamically load it **) val set_current : (module Container_SIG) -> unit (** sets a new 'inequalities reasoner'. This function is intended to be used by dynamically loaded plugins **) alt-ergo-1.30/src/theories/ac.ml0000644000175000001440000002210413014515065015040 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format module HS = Hstring module Sy = Symbols module type S = sig (* embeded AC semantic values *) type r (* extracted AC semantic values *) type t = r Sig.ac (* builds an embeded semantic value from an AC term *) val make : Term.t -> r * Literal.LT.t list (* tells whether the given term is AC*) val is_mine_symb : Sy.t -> bool (* compares two AC semantic values *) val compare : t -> t -> int (* tests if two values are equal (using tags) *) val equal : t -> t -> bool (* hash function for ac values *) val hash : t -> int (* returns the type infos of the given term *) val type_info : t -> Ty.t (* prints the AC semantic value *) val print : formatter -> t -> unit (* returns the leaves of the given AC semantic value *) val leaves : t -> r list (* replaces the first argument by the second one in the given AC value *) val subst : r -> r -> t -> r (* add flatten the 2nd arg w.r.t HS.t, add it to the given list and compact the result *) val add : Symbols.t -> r * int -> (r * int) list -> (r * int) list val fully_interpreted : Symbols.t -> bool val abstract_selectors : t -> (r * r) list -> r * (r * r) list val compact : (r * int) list -> (r * int) list end module Make (X : Sig.X) = struct open Sig type r = X.r type t = X.r Sig.ac (*BISECT-IGNORE-BEGIN*) module Debug = struct let print_x fmt v = match X.leaves v with | [w] when X.equal v w -> fprintf fmt "%a" X.print v | _ -> fprintf fmt "(%a)" X.print v let rec pr_elt sep fmt (e,n) = assert (n >=0); if n = 0 then () else fprintf fmt "%s%a%a" sep print_x e (pr_elt sep) (e,n-1) let pr_xs sep fmt = function | [] -> assert false | (p,n)::l -> fprintf fmt "%a" print_x p; List.iter (fprintf fmt "%a" (pr_elt sep))((p,n-1)::l) let print fmt {h=h ; l=l} = if Sy.equal h (Sy.Op Sy.Mult) && term_like_pp () then fprintf fmt "%a" (pr_xs "'*'") l else fprintf fmt "%a(%a)" Sy.print h (pr_xs ",") l let assert_compare a b c1 c2 = assert ( if not (c1 = 0 && c2 = 0 || c1 < 0 && c2 > 0 || c1 > 0 && c2 < 0) then begin fprintf fmt "Ac.compare:@.%a vs @.%a@. = %d@.@." print a print b c1; fprintf fmt "But@."; fprintf fmt "Ac.compare:@.%a vs @.%a@. = %d@.@." print b print a c2; false end else true ) let subst p v tm = if debug_ac () then fprintf fmt "[ac] subst %a by %a in %a@." X.print p X.print v X.print (X.ac_embed tm) end (*BISECT-IGNORE-END*) let print = Debug.print let flatten h (r,m) acc = match X.ac_extract r with | Some ac when Sy.equal ac.h h -> List.fold_left (fun z (e,n) -> (e,m * n) :: z) acc ac.l | _ -> (r,m) :: acc let sort = List.fast_sort (fun (x,n) (y,m) -> X.str_cmp x y) let rev_sort l = List.rev (sort l) let compact xs = let rec f acc = function | [] -> acc | [(x,n)] -> (x,n) :: acc | (x,n) :: (y,m) :: r -> if X.equal x y then f acc ((x,n+m) :: r) else f ((x,n)::acc) ((y,m) :: r) in f [] (sort xs) (* increasing order - f's result in a decreasing order*) let fold_flatten sy f = List.fold_left (fun z (rt,n) -> flatten sy ((f rt),n) z) [] let expand = List.fold_left (fun l (x,n) -> let l= ref l in for i=1 to n do l:=x::!l done; !l) [] let abstract2 sy t r acc = match X.ac_extract r with | Some ac when Sy.equal sy ac.h -> r, acc | None -> r, acc | Some _ -> match Term.view t with | {Term.f=Sy.Name(hs,Sy.Ac) ;xs=xs;ty=ty} -> let aro_sy = Sy.name ("@" ^ (HS.view hs)) in let aro_t = Term.make aro_sy xs ty in let eq = Literal.LT.mk_eq aro_t t in X.term_embed aro_t, eq::acc | {Term.f=Sy.Op Sy.Mult ;xs=xs;ty=ty} -> let aro_sy = Sy.name "@*" in let aro_t = Term.make aro_sy xs ty in let eq = Literal.LT.mk_eq aro_t t in X.term_embed aro_t, eq::acc | {Term.ty=ty} -> let k = Term.fresh_name ty in let eq = Literal.LT.mk_eq k t in X.term_embed k, eq::acc let make t = Options.exec_timer_start Timers.M_AC Timers.F_make; let x = match Term.view t with | {Term.f= sy; xs=[a;b]; ty=ty} when Sy.is_ac sy -> let ra, ctx1 = X.make a in let rb, ctx2 = X.make b in let ra, ctx = abstract2 sy a ra (ctx1 @ ctx2) in let rb, ctx = abstract2 sy b rb ctx in let rxs = [ ra,1 ; rb,1 ] in X.ac_embed {h=sy; l=compact (fold_flatten sy (fun x -> x) rxs); t=ty; distribute = true}, ctx | _ -> assert false in Options.exec_timer_pause Timers.M_AC Timers.F_make; x let is_mine_symb sy = Options.no_ac() == false && Sy.is_ac sy let type_info {t=ty} = ty let leaves { l=l } = List.fold_left (fun z (a,_) -> (X.leaves a) @ z)[] l let rec mset_cmp = function | [] , [] -> 0 | [] , _::_ -> -1 | _::_ , [] -> 1 | (a,m)::r , (b,n)::s -> let c = X.str_cmp a b in if c <> 0 then c else let c = m - n in if c <> 0 then c else mset_cmp(r,s) let size = List.fold_left (fun z (rx,n) -> z + n) 0 module SX = Set.Make(struct type t=r let compare = X.str_cmp end) let leaves_list l = let l = List.fold_left (fun acc (x,n) -> let sx = List.fold_right SX.add (X.leaves x) SX.empty in SX.fold (fun lv acc -> (lv, n) :: acc) sx acc ) []l in compact l (* x et y are sorted in a decreasing order *) let compare {h=f ; l=x} {h=g ; l=y} = let c = Sy.compare f g in if c <> 0 then c else let llx = leaves_list x in let lly = leaves_list y in let c = size llx - size lly in if c <> 0 then c else let c = mset_cmp (leaves_list x , leaves_list y) in if c <> 0 then c else mset_cmp (x , y) let compare a b = let c1 = compare a b in let c2 = compare b a in Debug.assert_compare a b c1 c2; c1 (* let mset_compare ord {h=f ; l=x} {h=g ; l=y} = let c = Sy.compare f g in if c <> 0 then c else assert false *) let equal {h=f ; l=lx} {h=g ; l=ly} = Sy.equal f g && try List.for_all2 (fun (x, m) (y, n) -> m = n && X.equal x y) lx ly with Invalid_argument _ -> false let hash {h = f ; l = l; t = t} = let acc = Sy.hash f + 19 * Ty.hash t in abs (List.fold_left (fun acc (x, y) -> acc + 19 * (X.hash x + y)) acc l) let subst p v ({h=h;l=l;t=t} as tm) = Options.exec_thread_yield (); Options.exec_timer_start Timers.M_AC Timers.F_subst; Debug.subst p v tm; let t = X.color {tm with l=compact (fold_flatten h (X.subst p v) l)} in Options.exec_timer_pause Timers.M_AC Timers.F_subst; t let add h arg arg_l = Options.exec_timer_start Timers.M_AC Timers.F_add; let r = compact (flatten h arg arg_l) in Options.exec_timer_pause Timers.M_AC Timers.F_add; r let fully_interpreted sb = true let abstract_selectors ({l=args} as ac) acc = let args, acc = List.fold_left (fun (args, acc) (r, i) -> let r, acc = X.abstract_selectors r acc in (r, i) :: args, acc )([],acc) args in let xac = X.ac_embed {ac with l = compact args} in xac, acc (* Ne suffit pas. Il faut aussi prevoir le collapse ? *) (*try List.assoc xac acc, acc with Not_found -> let v = X.term_embed (Term.fresh_name ac.t) in v, (xac, v) :: acc*) end alt-ergo-1.30/src/theories/sum.ml0000644000175000001440000003275413014515065015275 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format open Sig open Exception module Sy = Symbols module T = Term module A = Literal module L = List module Hs = Hstring module Ex = Explanation type 'a abstract = Cons of Hs.t * Ty.t | Alien of 'a module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) = struct type t = X.r abstract type r = X.r let name = "Sum" let is_mine_symb = function | Sy.Name(_, Sy.Constructor) -> true | _ -> false let fully_interpreted sb = true let type_info = function | Cons (_, ty) -> ty | Alien x -> X.type_info x let color _ = assert false (*BISECT-IGNORE-BEGIN*) module Debug = struct let print fmt = function | Cons (hs,ty) -> fprintf fmt "%s" (Hs.view hs) | Alien x -> fprintf fmt "%a" X.print x let solve_bis a b = if debug_sum () then fprintf fmt "[Sum] we solve %a = %a@." X.print a X.print b let solve_bis_result res = if debug_sum () then match res with | [p,v] -> fprintf fmt "\twe get: %a |-> %a@." X.print p X.print v | [] -> fprintf fmt "\tthe equation is trivial@." | _ -> assert false let solve_bis_unsolvable () = if debug_sum () then fprintf fmt "\tthe equation is unsolvable@." end (*BISECT-IGNORE-END*) let print = Debug.print let embed r = match X.extract r with | Some c -> c | None -> Alien r let is_mine = function | Alien r -> r | Cons(hs,ty) as c -> X.embed c let compare_mine c1 c2 = match c1 , c2 with | Cons (h1,ty1) , Cons (h2,ty2) -> let n = Hs.compare h1 h2 in if n <> 0 then n else Ty.compare ty1 ty2 | Alien r1, Alien r2 -> X.str_cmp r1 r2 | Alien _ , Cons _ -> 1 | Cons _ , Alien _ -> -1 let compare x y = compare_mine (embed x) (embed y) let equal s1 s2 = match s1, s2 with | Cons (h1,ty1) , Cons (h2,ty2) -> Hs.equal h1 h2 && Ty.equal ty1 ty2 | Alien r1, Alien r2 -> X.equal r1 r2 | Alien _ , Cons _ | Cons _ , Alien _ -> false let hash = function | Cons (h, ty) -> Hstring.hash h + 19 * Ty.hash ty | Alien r -> X.hash r let leaves _ = [] let subst p v c = let cr = is_mine c in if X.equal p cr then v else match c with | Cons(hs,t) -> cr | Alien r -> X.subst p v r let make t = match T.view t with | {T.f=Sy.Name(hs, Sy.Constructor); xs=[];ty=ty} -> is_mine (Cons(hs,ty)), [] | _ -> assert false let solve a b = match embed a, embed b with | Cons(c1,_) , Cons(c2,_) when Hs.equal c1 c2 -> [] | Cons(c1,_) , Cons(c2,_) -> raise Unsolvable | Cons _ , Alien r2 -> [r2,a] | Alien r1 , Cons _ -> [r1,b] | Alien _ , Alien _ -> if X.str_cmp a b > 0 then [a,b] else [b,a] let solve_bis a b = Debug.solve_bis a b; try let res = solve a b in Debug.solve_bis_result res; res with Unsolvable -> Debug.solve_bis_unsolvable (); raise Unsolvable let abstract_selectors v acc = is_mine v, acc let term_extract _ = None, false let solve r1 r2 pb = {pb with sbt = List.rev_append (solve_bis r1 r2) pb.sbt} let solve r1 r2 pb = if Options.timers() then try Options.exec_timer_start Timers.M_Sum Timers.F_solve; let res = solve r1 r2 pb in Options.exec_timer_pause Timers.M_Sum Timers.F_solve; res with e -> Options.exec_timer_pause Timers.M_Sum Timers.F_solve; raise e else solve r1 r2 pb let assign_value r _ _ = (* values of theory sum should be assigned by case_split *) None let choose_adequate_model t r l = let l = List.filter (fun (_, r) -> match embed r with Cons _ -> true | _ -> false) l in let r = match l with | (_,r)::l -> List.iter (fun (_,x) -> assert (X.equal x r)) l; r | [] -> (* We do this, because terms of some semantic values created by CS are not created and added to UF *) match embed r with Cons _ -> r | _ -> assert false in ignore (flush_str_formatter ()); fprintf str_formatter "%a" print (embed r); r, flush_str_formatter () end module Relation (X : ALIEN) (Uf : Uf.S) = struct type r = X.r type uf = Uf.t module Sh = Shostak(X) open Sh exception Not_Cons module Ex = Explanation module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) module HSS = Set.Make (struct type t=Hs.t let compare = Hs.compare end) module LR = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) type t = { mx : (HSS.t * Ex.t) MX.t; classes : Term.Set.t list; size_splits : Numbers.Q.t } let empty classes = { mx = MX.empty; classes = classes; size_splits = Numbers.Q.one } (*BISECT-IGNORE-BEGIN*) module Debug = struct let assume bol r1 r2 = if debug_sum () then fprintf fmt "[Sum.Rel] we assume %a %s %a@." X.print r1 (if bol then "=" else "<>") X.print r2 let print_env env = if debug_sum () then begin fprintf fmt "--SUM env ---------------------------------@."; MX.iter (fun r (hss, ex) -> fprintf fmt "%a ::= " X.print r; begin match HSS.elements hss with [] -> () | hs :: l -> fprintf fmt " %s" (Hs.view hs); L.iter (fun hs -> fprintf fmt " | %s" (Hs.view hs)) l end; fprintf fmt " : %a@." Ex.print ex; ) env.mx; fprintf fmt "-------------------------------------------@."; end let case_split r r' = if debug_sum () then fprintf fmt "[case-split] %a = %a@." X.print r X.print r' let no_case_split () = if debug_sum () then fprintf fmt "[case-split] sum: nothing@." let add r = if debug_sum () then fprintf fmt "Sum.Rel.add: %a@." X.print r end (*BISECT-IGNORE-END*) let values_of r = match X.type_info r with | Ty.Tsum (_,l) -> Some (List.fold_left (fun st hs -> HSS.add hs st) HSS.empty l) | _ -> None let add_diseq hss sm1 sm2 dep env eqs = match sm1, sm2 with | Alien r , Cons(h,ty) | Cons (h,ty), Alien r -> let enum, ex = try MX.find r env.mx with Not_found -> hss, Ex.empty in let enum = HSS.remove h enum in let ex = Ex.union ex dep in if HSS.is_empty enum then raise (Inconsistent (ex, env.classes)) else let env = { env with mx = MX.add r (enum, ex) env.mx } in if HSS.cardinal enum = 1 then let h' = HSS.choose enum in env, (LSem (LR.mkv_eq r (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else env, eqs | Alien r1, Alien r2 -> let enum1,ex1= try MX.find r1 env.mx with Not_found -> hss,Ex.empty in let enum2,ex2= try MX.find r2 env.mx with Not_found -> hss,Ex.empty in let eqs = if HSS.cardinal enum1 = 1 then let ex = Ex.union dep ex1 in let h' = HSS.choose enum1 in let ty = X.type_info r1 in (LSem (LR.mkv_eq r1 (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else eqs in let eqs = if HSS.cardinal enum2 = 1 then let ex = Ex.union dep ex2 in let h' = HSS.choose enum2 in let ty = X.type_info r2 in (LSem (LR.mkv_eq r2 (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else eqs in env, eqs | _ -> env, eqs let add_eq hss sm1 sm2 dep env eqs = match sm1, sm2 with | Alien r, Cons(h,ty) | Cons (h,ty), Alien r -> let enum, ex = try MX.find r env.mx with Not_found -> hss, Ex.empty in let ex = Ex.union ex dep in if not (HSS.mem h enum) then raise (Inconsistent (ex, env.classes)); {env with mx = MX.add r (HSS.singleton h, ex) env.mx} , eqs | Alien r1, Alien r2 -> let enum1,ex1 = try MX.find r1 env.mx with Not_found -> hss, Ex.empty in let enum2,ex2 = try MX.find r2 env.mx with Not_found -> hss, Ex.empty in let ex = Ex.union dep (Ex.union ex1 ex2) in let diff = HSS.inter enum1 enum2 in if HSS.is_empty diff then raise (Inconsistent (ex, env.classes)); let mx = MX.add r1 (diff, ex) env.mx in let env = {env with mx = MX.add r2 (diff, ex) mx } in if HSS.cardinal diff = 1 then let h' = HSS.choose diff in let ty = X.type_info r1 in env, (LSem (LR.mkv_eq r1 (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else env, eqs | _ -> env, eqs let count_splits env la = let nb = List.fold_left (fun nb (_,_,_,i) -> match i with | CS (Th_sum, n) -> Numbers.Q.mult nb n | _ -> nb )env.size_splits la in {env with size_splits = nb} let add_aux env r = Debug.add r; match embed r, values_of r with | Alien r, Some hss -> if MX.mem r env.mx then env else { env with mx = MX.add r (hss, Ex.empty) env.mx } | _ -> env (* needed for models generation because fresh terms are not added with function add *) let add_rec env r = List.fold_left add_aux env (X.leaves r) let assume env uf la = let env = count_splits env la in let classes = Uf.cl_extract uf in let env = { env with classes = classes } in let aux bol r1 r2 dep env eqs = function | None -> env, eqs | Some hss -> Debug.assume bol r1 r2; if bol then add_eq hss (embed r1) (embed r2) dep env eqs else add_diseq hss (embed r1) (embed r2) dep env eqs in Debug.print_env env; let env, eqs = List.fold_left (fun (env,eqs) -> function | A.Eq(r1,r2), _, ex, _ -> (* needed for models generation because fresh terms are not added with function add *) let env = add_rec (add_rec env r1) r2 in aux true r1 r2 ex env eqs (values_of r1) | A.Distinct(false, [r1;r2]), _, ex, _ -> (* needed for models generation because fresh terms are not added with function add *) let env = add_rec (add_rec env r1) r2 in aux false r1 r2 ex env eqs (values_of r1) | _ -> env, eqs ) (env,[]) la in env, { assume = eqs; remove = [] } let add env _ r _ = add_aux env r let case_split env uf ~for_model = let acc = MX.fold (fun r (hss, ex) acc -> let sz = HSS.cardinal hss in if sz = 1 then acc else match acc with | Some (n,r,hs) when n <= sz -> acc | _ -> Some (sz, r, HSS.choose hss) ) env.mx None in match acc with | Some (n,r,hs) -> let n = Numbers.Q.from_int n in if for_model || Numbers.Q.compare (Numbers.Q.mult n env.size_splits) (max_split ()) <= 0 || Numbers.Q.sign (max_split ()) < 0 then let r' = is_mine (Cons(hs,X.type_info r)) in Debug.case_split r r'; [LR.mkv_eq r r', true, CS(Th_sum, n)] else [] | None -> Debug.no_case_split (); [] let query env uf a_ex = try ignore(assume env uf [a_ex]); Sig.No with Inconsistent (expl, classes) -> Sig.Yes (expl, classes) let assume env uf la = if Options.timers() then try Options.exec_timer_start Timers.M_Sum Timers.F_assume; let res =assume env uf la in Options.exec_timer_pause Timers.M_Sum Timers.F_assume; res with e -> Options.exec_timer_pause Timers.M_Sum Timers.F_assume; raise e else assume env uf la let query env uf la = if Options.timers() then try Options.exec_timer_start Timers.M_Sum Timers.F_query; let res = query env uf la in Options.exec_timer_pause Timers.M_Sum Timers.F_query; res with e -> Options.exec_timer_pause Timers.M_Sum Timers.F_query; raise e else query env uf la let instantiate env _ _ _ _ = env, [] let print_model _ _ _ = () let new_terms env = Term.Set.empty end alt-ergo-1.30/src/theories/sum.mli0000644000175000001440000000362413014515065015440 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-1.30/src/theories/bitv.mli0000644000175000001440000000362413014515065015600 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-1.30/src/theories/ac.mli0000644000175000001440000000554013014515065015216 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module type S = sig (* the type of amalgamated AC semantic values *) type r (* the type of AC semantic values used by the theory *) type t = r Sig.ac (* builds an embeded semantic value from an AC term *) val make : Term.t -> r * Literal.LT.t list (* tells whether the given term is AC*) val is_mine_symb : Symbols.t -> bool (* compares two AC semantic values *) val compare : t -> t -> int (* tests if two values are equal (using tags) *) val equal : t -> t -> bool (* hash function for ac values *) val hash : t -> int (* returns the type infos of the given term *) val type_info : t -> Ty.t (* prints the AC semantic value *) val print : Format.formatter -> t -> unit (* returns the leaves of the given AC semantic value *) val leaves : t -> r list (* replaces the first argument by the second one in the given AC value *) val subst : r -> r -> t -> r (* add flatten the 2nd arg w.r.t HS.t, add it to the given list and compact the result *) val add : Symbols.t -> r * int -> (r * int) list -> (r * int) list val fully_interpreted : Symbols.t -> bool val abstract_selectors : t -> (r * r) list -> r * (r * r) list val compact : (r * int) list -> (r * int) list end module Make (X : Sig.X) : S with type r = X.r alt-ergo-1.30/src/theories/arrays.ml0000644000175000001440000004123013014515065015757 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format open Sig module Sy = Symbols module T = Term module A = Literal module L = List type 'a abstract = unit module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) = struct type t = X.r abstract type r = X.r let name = "Farrays" let is_mine_symb _ = false let fully_interpreted sb = assert false let type_info _ = assert false let color _ = assert false let print _ _ = assert false let embed _ = assert false let is_mine _ = assert false let compare _ _ = assert false let equal _ _ = assert false let hash _ = assert false let leaves _ = assert false let subst _ _ _ = assert false let make _ = assert false let term_extract _ = None, false let abstract_selectors p acc = assert false let solve r1 r2 = assert false let assign_value r _ eq = if List.exists (fun (t,_) -> (Term.view t).Term.depth = 1) eq then None else match X.term_extract r with | Some t, true -> Some (Term.fresh_name (X.type_info r), false) | _ -> assert false let choose_adequate_model t _ l = let acc = List.fold_left (fun acc (s, r) -> if (Term.view s).Term.depth <> 1 then acc else match acc with | Some(s', r') when Term.compare s' s > 0 -> acc | _ -> Some (s, r) ) None l in match acc with | Some (_, r) -> ignore (flush_str_formatter ()); fprintf str_formatter "%a" X.print r; (* it's a EUF constant *) r, flush_str_formatter () | _ -> assert false end module Relation (X : ALIEN) (Uf : Uf.S) = struct open Sig module Ex = Explanation type r = X.r type uf = Uf.t module LR = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) (* map get |-> { set } des associations (get,set) deja splites *) module Tmap = struct include T.Map let update t a mp = try add t (T.Set.add a (find t mp)) mp with Not_found -> add t (T.Set.singleton a) mp let splited t a mp = try T.Set.mem a (find t mp) with Not_found -> false end module LRset= LR.Set module Conseq = Set.Make (struct type t = A.LT.t * Ex.t let compare (lt1,_) (lt2,_) = A.LT.compare lt1 lt2 end) (* map k |-> {sem Atom} d'egalites/disegalites sur des atomes semantiques*) module LRmap = struct include LR.Map let find k mp = try find k mp with Not_found -> Conseq.empty let add k v ex mp = add k (Conseq.add (v,ex) (find k mp)) mp end type gtype = {g:Term.t; gt:Term.t; gi:Term.t; gty:Ty.t} module G :Set.S with type elt = gtype = Set.Make (struct type t = gtype let compare t1 t2 = T.compare t1.g t2.g end) (* ensemble de termes "set" avec leurs arguments et leurs types *) type stype = {s:T.t; st:T.t; si:T.t; sv:T.t; sty:Ty.t} module S :Set.S with type elt = stype = Set.Make (struct type t = stype let compare t1 t2 = T.compare t1.s t2.s end) (* map t |-> {set(t,-,-)} qui associe a chaque tableau l'ensemble de ses affectations *) module TBS = struct include Map.Make(T) let find k mp = try find k mp with Not_found -> S.empty (* add reutilise find ci-dessus *) let add k v mp = add k (S.add v (find k mp)) mp end type t = {gets : G.t; (* l'ensemble des "get" croises*) tbset : S.t TBS.t ; (* map t |-> set(t,-,-) *) split : LRset.t; (* l'ensemble des case-split possibles *) conseq : Conseq.t LRmap.t; (* consequences des splits *) seen : T.Set.t Tmap.t; (* combinaisons (get,set) deja splitees *) new_terms : T.Set.t; size_splits : Numbers.Q.t; } let empty _ = {gets = G.empty; tbset = TBS.empty; split = LRset.empty; conseq = LRmap.empty; seen = Tmap.empty; new_terms = T.Set.empty; size_splits = Numbers.Q.one; } (*BISECT-IGNORE-BEGIN*) module Debug = struct let assume fmt la = if debug_arrays () && la != [] then begin fprintf fmt "[Arrays.Rel] We assume@."; L.iter (fun (a,_,_,_) -> fprintf fmt " > %a@." LR.print (LR.make a)) la; end let print_gets fmt = G.iter (fun t -> fprintf fmt "%a@." T.print t.g) let print_sets fmt = S.iter (fun t -> fprintf fmt "%a@." T.print t.s) let print_splits fmt = LRset.iter (fun a -> fprintf fmt "%a@." LR.print a) let print_tbs fmt = TBS.iter (fun k v -> fprintf fmt "%a --> %a@." T.print k print_sets v) let env fmt env = if debug_arrays () then begin fprintf fmt "-- gets ----------------------------------------@."; print_gets fmt env.gets; fprintf fmt "-- tabs of sets --------------------------------@."; print_tbs fmt env.tbset; fprintf fmt "-- splits --------------------------------------@."; print_splits fmt env.split; fprintf fmt "------------------------------------------------@." end let new_equalities fmt st = if debug_arrays () then begin fprintf fmt "[Arrays] %d implied equalities@." (Conseq.cardinal st); Conseq.iter (fun (a,ex) -> fprintf fmt " %a : %a@." A.LT.print a Ex.print ex) st end let case_split a = if debug_arrays () then fprintf fmt "[Arrays.case-split] %a@." LR.print a let case_split_none () = if debug_arrays () then fprintf fmt "[Arrays.case-split] Nothing@." end (*BISECT-IGNORE-END*) (* met a jour gets et tbset en utilisant l'ensemble des termes donne*) let rec update_gets_sets acc t = let {T.f=f;xs=xs;ty=ty} = T.view t in let gets, tbset = List.fold_left update_gets_sets acc xs in match Sy.is_get f, Sy.is_set f, xs with | true , false, [a;i] -> G.add {g=t; gt=a; gi=i; gty=ty} gets, tbset | false, true , [a;i;v] -> gets, TBS.add a {s=t; st=a; si=i; sv=v; sty=ty} tbset | false, false, _ -> (gets,tbset) | _ -> assert false (* met a jour les composantes gets et tbset de env avec les termes contenus dans les atomes de la *) let new_terms env la = let fct acc r = List.fold_left (fun acc x -> match X.term_extract x with | Some t, _ -> update_gets_sets acc t | None, _ -> acc )acc (X.leaves r) in let gets, tbset = L.fold_left (fun acc (a,_,_,_)-> match a with | A.Eq (r1,r2) -> fct (fct acc r1) r2 | A.Builtin (_,_,l) | A.Distinct (_, l) -> L.fold_left fct acc l | A.Pred (r1,_) -> fct acc r1 ) (env.gets,env.tbset) la in {env with gets=gets; tbset=tbset} (* mise a jour de env avec les instances 1) p => p_ded 2) n => n_ded *) let update_env are_eq are_dist dep env acc gi si p p_ded n n_ded = match are_eq gi si, are_dist gi si with | Sig.Yes (idep, _) , Sig.No -> let conseq = LRmap.add n n_ded dep env.conseq in {env with conseq = conseq}, Conseq.add (p_ded, Ex.union dep idep) acc | Sig.No, Sig.Yes (idep, _) -> let conseq = LRmap.add p p_ded dep env.conseq in {env with conseq = conseq}, Conseq.add (n_ded, Ex.union dep idep) acc | Sig.No, Sig.No -> let sp = LRset.add p env.split in let conseq = LRmap.add p p_ded dep env.conseq in let conseq = LRmap.add n n_ded dep conseq in { env with split = sp; conseq = conseq }, acc | Sig.Yes _, Sig.Yes _ -> assert false (*---------------------------------------------------------------------- get(set(-,-,-),-) modulo egalite ---------------------------------------------------------------------*) let get_of_set are_eq are_dist gtype (env,acc) class_of = let {g=get; gt=gtab; gi=gi; gty=gty} = gtype in L.fold_left (fun (env,acc) set -> if Tmap.splited get set env.seen then (env,acc) else let env = {env with seen = Tmap.update get set env.seen} in let {T.f=f;xs=xs;ty=sty} = T.view set in match Sy.is_set f, xs with | true , [stab;si;sv] -> let xi, _ = X.make gi in let xj, _ = X.make si in let get_stab = T.make (Sy.Op Sy.Get) [stab;gi] gty in let p = LR.mk_eq xi xj in let p_ded = A.LT.mk_eq get sv in let n = LR.mk_distinct false [xi;xj] in let n_ded = A.LT.mk_eq get get_stab in let dep = match are_eq gtab set with Yes (dep, _) -> dep | No -> assert false in let env = {env with new_terms = T.Set.add get_stab env.new_terms } in update_env are_eq are_dist dep env acc gi si p p_ded n n_ded | _ -> (env,acc) ) (env,acc) (class_of gtab) (*---------------------------------------------------------------------- set(-,-,-) modulo egalite ---------------------------------------------------------------------*) let get_from_set are_eq are_dist stype (env,acc) class_of = let {s=set; st=stab; si=si; sv=sv; sty=sty} = stype in let ty_si = (T.view sv).T.ty in let stabs = L.fold_left (fun acc t -> S.union acc (TBS.find t env.tbset)) S.empty (class_of stab) in S.fold (fun stab' (env,acc) -> let get = T.make (Sy.Op Sy.Get) [set; si] ty_si in if Tmap.splited get set env.seen then (env,acc) else let env = {env with seen = Tmap.update get set env.seen; new_terms = T.Set.add get env.new_terms } in let p_ded = A.LT.mk_eq get sv in env, Conseq.add (p_ded, Ex.empty) acc ) stabs (env,acc) (*---------------------------------------------------------------------- get(t,-) and set(t,-,-) modulo egalite ---------------------------------------------------------------------*) let get_and_set are_eq are_dist gtype (env,acc) class_of = let {g=get; gt=gtab; gi=gi; gty=gty} = gtype in let suff_sets = L.fold_left (fun acc t -> S.union acc (TBS.find t env.tbset)) S.empty (class_of gtab) in S.fold (fun {s=set; st=stab; si=si; sv=sv; sty=sty} (env,acc) -> if Tmap.splited get set env.seen then (env,acc) else begin let env = {env with seen = Tmap.update get set env.seen} in let xi, _ = X.make gi in let xj, _ = X.make si in let get_stab = T.make (Sy.Op Sy.Get) [stab;gi] gty in let gt_of_st = T.make (Sy.Op Sy.Get) [set;gi] gty in let p = LR.mk_eq xi xj in let p_ded = A.LT.mk_eq gt_of_st sv in let n = LR.mk_distinct false [xi;xj] in let n_ded = A.LT.mk_eq gt_of_st get_stab in let dep = match are_eq gtab stab with Yes (dep, _) -> dep | No -> assert false in let env = {env with new_terms = T.Set.add get_stab (T.Set.add gt_of_st env.new_terms) } in update_env are_eq are_dist dep env acc gi si p p_ded n n_ded end ) suff_sets (env,acc) (* Generer de nouvelles instantiations de lemmes *) let new_splits are_eq are_dist env acc class_of = let accu = G.fold (fun gt_info accu -> let accu = get_of_set are_eq are_dist gt_info accu class_of in get_and_set are_eq are_dist gt_info accu class_of ) env.gets (env,acc) in TBS.fold (fun _ tbs accu -> S.fold (fun stype accu -> get_from_set are_eq are_dist stype accu class_of) tbs accu ) env.tbset accu (* nouvelles disegalites par instantiation du premier axiome d'exentionnalite *) let extensionality accu la class_of = List.fold_left (fun ((env, acc) as accu) (a, _, dep,_) -> match a with | A.Distinct(false, [r;s]) -> begin match X.type_info r, X.term_extract r, X.term_extract s with | Ty.Tfarray (ty_k, ty_v), (Some t1, _), (Some t2, _) -> let i = T.fresh_name ty_k in let g1 = T.make (Sy.Op Sy.Get) [t1;i] ty_v in let g2 = T.make (Sy.Op Sy.Get) [t2;i] ty_v in let d = A.LT.mk_distinct false [g1;g2] in let acc = Conseq.add (d, dep) acc in let env = {env with new_terms = T.Set.add g2 (T.Set.add g1 env.new_terms) } in env, acc | _ -> accu end | _ -> accu ) accu la let implied_consequences env eqs la = let spl, eqs = L.fold_left (fun (spl,eqs) (a,_,dep,_) -> let a = LR.make a in let spl = LRset.remove (LR.neg a) (LRset.remove a spl) in let eqs = Conseq.fold (fun (fact,ex) acc -> Conseq.add (fact, Ex.union ex dep) acc) (LRmap.find a env.conseq) eqs in spl, eqs )(env.split, eqs) la in {env with split=spl}, eqs (* deduction de nouvelles dis/egalites *) let new_equalities env eqs la class_of = let la = L.filter (fun (a,_,_,_) -> match a with A.Builtin _ -> false | _ -> true) la in let env, eqs = extensionality (env, eqs) la class_of in implied_consequences env eqs la (* choisir une egalite sur laquelle on fait un case-split *) let two = Numbers.Q.from_int 2 let case_split env uf ~for_model = (*if Numbers.Q.compare (Numbers.Q.mult two env.size_splits) (max_split ()) <= 0 || Numbers.Q.sign (max_split ()) < 0 then*) try let a = LR.neg (LRset.choose env.split) in Debug.case_split a; [LR.view a, true, CS (Th_arrays, two)] with Not_found -> Debug.case_split_none (); [] let count_splits env la = let nb = List.fold_left (fun nb (_,_,_,i) -> match i with | CS (Th_arrays, n) -> Numbers.Q.mult nb n | _ -> nb )env.size_splits la in {env with size_splits = nb} let assume env uf la = let are_eq = Uf.are_equal uf ~added_terms:true in let are_neq = Uf.are_distinct uf in let class_of = Uf.class_of uf in let env = count_splits env la in (* instantiation des axiomes des tableaux *) Debug.assume fmt la; let env = new_terms env la in let env, atoms = new_splits are_eq are_neq env Conseq.empty class_of in let env, atoms = new_equalities env atoms la class_of in (*Debug.env fmt env;*) Debug.new_equalities fmt atoms; let l = Conseq.fold (fun (a,ex) l -> ((LTerm a, ex, Sig.Other)::l)) atoms [] in env, { assume = l; remove = [] } let assume env uf la = if Options.timers() then try Options.exec_timer_start Timers.M_Arrays Timers.F_assume; let res =assume env uf la in Options.exec_timer_pause Timers.M_Arrays Timers.F_assume; res with e -> Options.exec_timer_pause Timers.M_Arrays Timers.F_assume; raise e else assume env uf la let query _ _ _ = Sig.No let add env _ r _ = env let print_model _ _ _ = () let new_terms env = env.new_terms end alt-ergo-1.30/src/theories/inequalities.ml0000644000175000001440000003431713014515065017162 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options module Z = Numbers.Z module Q = Numbers.Q module type S = sig module P : Polynome.EXTENDED_Polynome module MP : Map.S with type key = P.t type t = { ple0 : P.t; is_le : bool; (* int instead of Literal.LT.t as a key to prevent us from using it in deductions *) dep : (Q.t * P.t * bool) Util.MI.t; expl : Explanation.t; age : Z.t; } module MINEQS : sig type mp = (t * Q.t) MP.t val empty : mp val is_empty : mp -> bool val younger : t -> t -> bool val insert : t -> mp -> mp val ineqs_of : mp -> t list val add_to_map : mp -> t list -> mp val iter : (P.t -> (t * Q.t) -> unit) -> mp -> unit val fold : (P.t -> (t * Q.t) -> 'a -> 'a) -> mp -> 'a -> 'a end val current_age : unit -> Numbers.Z.t val incr_age : unit -> unit val create_ineq : P.t -> P.t -> bool -> Literal.LT.t option -> Explanation.t -> t val print_inequation : Format.formatter -> t -> unit val fourierMotzkin : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val fmSimplex : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val available : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc end module type Container_SIG = sig module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P end module Container : Container_SIG = struct module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P = struct module P = P module MP = Map.Make(P) module SP = Set.Make(P) module SX = Set.Make(struct type t = X.r let compare = X.hash_cmp end) module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) type r = P.r type uf = Uf.t let age_cpt = ref Z.zero let current_age () = !age_cpt let incr_age () = age_cpt := Z.add !age_cpt Z.one; type t = { ple0 : P.t; is_le : bool; dep : (Q.t * P.t * bool) Util.MI.t; expl : Explanation.t; age : Z.t; } let print_inequation fmt ineq = fprintf fmt "%a %s 0 %a" P.print ineq.ple0 (if ineq.is_le then "<=" else "<") Explanation.print ineq.expl let create_ineq p1 p2 is_le a expl = let ple0 = P.sub p1 p2 in match P.to_list ple0 with | ([], ctt) when is_le && Q.sign ctt > 0-> raise (Intervals.NotConsistent expl) | ([], ctt) when not is_le && Q.sign ctt >= 0 -> raise (Intervals.NotConsistent expl) | _ -> let p,c,d = P.normal_form ple0 in (* ple0 = (p + c) * d, and d > 0 *) assert (Q.compare d Q.zero > 0); let c = if P.type_info p == Ty.Treal then c else (Q.ceiling c) in let p = P.add_const c p in let dep = match a with | Some a -> Util.MI.singleton (Literal.LT.uid a) (Q.one, p, is_le) | None -> Util.MI.empty in { ple0 = p; is_le = is_le; dep = dep; expl = expl; age = !age_cpt } let find_coefficient x ineq = P.find x ineq.ple0 let split_pos_neg _ ({ple0 = p ; age = age},_) (mx, nb_max) = let mx = List.fold_left (fun m (c,x) -> let cmp = Q.sign c in (* equiv. to compare c Q.zero *) if cmp = 0 then m else let (pos, neg) = try MX.find x m with Not_found -> (0,0) in if cmp > 0 then MX.add x (pos+1, neg) m else MX.add x (pos, neg+1) m ) mx (fst (P.to_list p)) in mx, if Z.equal age !age_cpt then nb_max + 1 else nb_max module MINEQS = struct type mp = (t * Q.t) MP.t let empty = MP.empty let is_empty mp = MP.is_empty mp let younger ineq' ineq = (* requires more work in Explanation Explanation.younger ineq'.expl ineq.expl ||*) Z.compare ineq'.age ineq.age <= 0 let insert ineq mp = (* ineq.ple0 == is == p0 + ctt <(=) 0 i.e. p0 <(=) -ctt *) let p0, ctt = P.separate_constant ineq.ple0 in try let ineq', ctt' = MP.find p0 mp in (* ineq'.ple0 == is == p0 + ctt' <(=) 0 i.e. p0 <(=) -ctt' *) let cmp = Q.compare ctt' ctt in if cmp = 0 then if ineq.is_le == ineq'.is_le then (* equivalent *) (* if ineq in older, we should update the map to have the right (most recent) age *) if younger ineq ineq' then mp else MP.add p0 (ineq, ctt) mp else if ineq.is_le then mp (* ineq' more precise, because it has < *) else MP.add p0 (ineq, ctt) mp (*ineq has < -c and ineq' <= -c *) else if cmp > 0 then (* i.e. ctt' > ctt, i.e. p0 <(=) -ctt' < -ctt *) mp (* ineq' is more precise *) else (* cmp < 0 i.e. ctt' < ctt, i.e. - ctt' > - ctt >(=) p0 *) MP.add p0 (ineq, ctt) mp (* ineq is more precise *) with Not_found -> MP.add p0 (ineq, ctt) mp let ineqs_of mp = MP.fold (fun _ (ineq, _) acc -> ineq :: acc) mp [] let add_to_map mp l = List.fold_left (fun mp v -> insert v mp) mp l let iter = MP.iter let fold = MP.fold end module Debug = struct let list_of_ineqs fmt = List.iter (fprintf fmt "%a " print_inequation) let map_of_ineqs fmt = MINEQS.iter (fun _ (i , _) -> fprintf fmt "%a " print_inequation i) let cross x vars cpos cneg others = if Options.debug_fm () then begin fprintf Options.fmt "[fm] We cross on %a (%d vars remaining)@." X.print x (MX.cardinal vars); fprintf Options.fmt "with:@. cpos = %a@. cneg = %a@. others = %a@." list_of_ineqs cpos list_of_ineqs cneg map_of_ineqs others end let cross_result x ninqs = if Options.debug_fm () then fprintf Options.fmt "result of eliminating %a: at most %d new ineqs (not printed)@." X.print x ninqs end let mult_list c dep = if Q.equal c Q.one then dep else Util.MI.fold (fun a (coef,p,is_le) dep -> Util.MI.add a (Q.mult coef c, p, is_le) dep )dep Util.MI.empty let merge_deps d1 d2 = Util.MI.merge (fun k op1 op2 -> match op1, op2 with | None, None -> None | Some _, None -> op1 | None, Some _ -> op2 | Some(c1,p1, is_le1), Some(c2,p2, is_le2) -> assert (P.equal p1 p2 && is_le1 == is_le2); Some (Q.add c1 c2, p1, is_le1) )d1 d2 let cross x cpos cneg mp = let nb_inqs = ref 0 in let rec cross_rec acc l = Options.exec_thread_yield (); match l with | [] -> acc | { ple0=p1; is_le=k1; dep=d1; expl=ex1; age=a1 }::l -> let n1 = Q.abs (P.find x p1) in let acc = List.fold_left (fun acc {ple0=p2; is_le=k2; dep=d2; expl=ex2; age=a2} -> Options.exec_thread_yield (); let n2 = Q.abs (P.find x p2) in let n1, n2 = (* light normalization of n1 and n2 *) if Q.equal n1 n2 then Q.one, Q.one else n1, n2 in let p = P.add (P.mult_const n2 p1) (P.mult_const n1 p2) in let p, c, d = P.normal_form p in (* light norm of p *) let p = P.add_const c p in assert (Q.sign d > 0); let d1 = mult_list (Q.div n2 d) d1 in let d2 = mult_list (Q.div n1 d) d2 in let ni = { ple0 = p; is_le = k1&&k2; dep = merge_deps d1 d2; age = Z.max a1 a2; expl = Explanation.union ex1 ex2 } in incr nb_inqs; MINEQS.insert ni acc ) acc cpos in cross_rec acc l in cross_rec mp cneg, !nb_inqs let split x mp = let rec split_rec _ (ineq, _) (cp, cn, co, nb_pos, nb_neg) = try let a = find_coefficient x ineq in if Q.sign a > 0 then ineq::cp, cn, co, nb_pos+1, nb_neg else cp, ineq::cn, co, nb_pos, nb_neg+1 with Not_found -> cp, cn, MINEQS.insert ineq co, nb_pos, nb_neg in MINEQS.fold split_rec mp ([], [], MINEQS.empty, 0, 0) let choose_var mp = let pos_neg, nb_max = MINEQS.fold split_pos_neg mp (MX.empty, 0) in if nb_max = 0 then raise Not_found; let xopt = MX.fold (fun x (pos, neg) acc -> match acc with | None -> Some (x, pos * neg) | Some (y, c') -> let c = pos * neg in if c < c' then Some (x, c) else acc ) pos_neg None in match xopt with | Some (x, _) -> x, pos_neg | None -> raise Not_found let monome_ineq ineq = P.is_monomial ineq.ple0 != None let fourierMotzkin add_ineqs are_eq acc mp = let rec fourier acc mp = Options.exec_thread_yield (); if MINEQS.is_empty mp then acc else try let x, vars = choose_var mp in let cpos, cneg, others, nb_pos, nb_neg = split x mp in Debug.cross x vars cpos cneg others; let s_x = Some x in let acc = add_ineqs are_eq acc s_x cpos in let acc = add_ineqs are_eq acc s_x cneg in let size_res = Q.from_int (nb_pos * nb_neg) in let mp', nb_inqs = if Q.compare size_res (fm_cross_limit ()) >= 0 && Q.sign (fm_cross_limit()) >= 0 then let u_cpos = List.filter monome_ineq cpos in let u_cneg = List.filter monome_ineq cneg in let mp', nb_inq1 = match u_cpos with | [] -> others, 0 | [_] -> cross x cneg u_cpos others | _ -> assert false (* normalization invariant *) in let mp', nb_inq2 = match u_cneg with | [] -> mp', 0 | [_] -> cross x cpos u_cneg mp' | _ -> assert false (* normalization invariant *) in mp', nb_inq1 + nb_inq2 else cross x cpos cneg others in Debug.cross_result x nb_inqs; fourier acc mp' with Not_found -> add_ineqs are_eq acc None (MINEQS.ineqs_of mp) in fourier acc mp let fmSimplex add_ineqs are_eq acc mp = let msg = "Not implemented in the default version!"^ "Use the FmSimplex plugin instead" in failwith msg let available = fourierMotzkin end end module FM = Container.Make let current = ref (module Container : Container_SIG) let initialized = ref false let set_current mdl = current := mdl let load_current_inequalities_reasoner () = match Options.inequalities_plugin () with | "" -> if Options.debug_fm () then eprintf "[Dynlink] Using the 'FM module' for arithmetic inequalities@." | path -> if Options.debug_fm () then eprintf "[Dynlink] Loading the 'inequalities' reasoner in %s ...@." path; try MyDynlink.loadfile path; if Options.debug_fm () then eprintf "Success !@.@." with | MyDynlink.Error m1 -> if Options.debug_fm() then begin eprintf "[Dynlink] Loading the 'inequalities' reasoner in \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; let prefixed_path = sprintf "%s/%s" Config.pluginsdir path in if Options.debug_fm () then eprintf "[Dynlink] Loading the 'inequalities' reasoner in %s with prefix %s@." path Config.pluginsdir; try MyDynlink.loadfile prefixed_path; if Options.debug_fm () then eprintf "Success !@.@." with | MyDynlink.Error m2 -> if not (Options.debug_fm()) then begin eprintf "[Dynlink] Loading the 'inequalities' reasoner in \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; eprintf "[Dynlink] Trying to load the plugin from \"%s\" failed too!@." prefixed_path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m2); exit 1 let get_current () = if not !initialized then begin load_current_inequalities_reasoner (); initialized := true; end; !current alt-ergo-1.30/src/theories/intervalCalculus.ml0000644000175000001440000016613313014515065020010 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig module Z = Numbers.Z module Q = Numbers.Q let ale = Hstring.make "<=" let alt = Hstring.make "<" let is_le n = Hstring.compare n ale = 0 let is_lt n = Hstring.compare n alt = 0 let (-@) l1 l2 = List.rev_append l1 l2 module L = Literal module Sy = Symbols module I = Intervals exception NotConsistent of Literal.LT.Set.t module OracleContainer = (val (Inequalities.get_current ()) : Inequalities.Container_SIG) module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) = struct module MP0 = Map.Make(P) module SP = Set.Make(P) module SX = Set.Make(struct type t = X.r let compare = X.hash_cmp end) module MX0 = Map.Make(struct type t = X.r let compare = X.hash_cmp end) module MPL = Literal.LT.Map module Oracle = OracleContainer.Make(X)(Uf)(P) type r = P.r type uf = Uf.t module LR = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) module MR = Map.Make( struct type t = r L.view let compare a b = LR.compare (LR.make a) (LR.make b) end) let alien_of p = match P.is_monomial p with | Some (a,x,b) when Q.equal a Q.one && Q.sign b = 0 -> x | _ -> P.embed p let poly_of r = match P.extract r with | Some p -> p | None -> P.create [Numbers.Q.one, r] Numbers.Q.zero (X.type_info r) module SimVar = struct type t = X.r let compare = X.hash_cmp let is_int r = X.type_info r == Ty.Tint let print fmt x = match P.extract x with | None -> fprintf fmt "%a" X.print x | Some p -> fprintf fmt "s!%d" (X.hash x) (* slake vars *) end module Sim = OcplibSimplex.Basic.Make(SimVar)(Numbers.Q)(Explanation) type t = { inequations : Oracle.t MPL.t; monomes: (I.t * SX.t) MX0.t; polynomes : I.t MP0.t; known_eqs : SX.t; improved_p : SP.t; improved_x : SX.t; classes : Term.Set.t list; size_splits : Q.t; int_sim : Sim.Core.t; rat_sim : Sim.Core.t; new_uf : uf; } module Sim_Wrap = struct let check_unsat_result simplex env = match Sim.Result.get None simplex with | Sim.Core.Unknown -> assert false | Sim.Core.Unbounded _ -> assert false | Sim.Core.Max _ -> assert false | Sim.Core.Sat _ -> () | Sim.Core.Unsat ex -> let ex = Lazy.force ex in if debug_fm() then fprintf fmt "[fm] simplex derived unsat: %a@." Explanation.print ex; raise (Exception.Inconsistent (ex, env.classes)) let solve env i = let int_sim = Sim.Solve.solve env.int_sim in check_unsat_result int_sim env; let rat_sim = Sim.Solve.solve env.rat_sim in check_unsat_result rat_sim env; {env with int_sim; rat_sim} let extract_bound i get_lb = let func, q = if get_lb then I.borne_inf, Q.one else I.borne_sup, Q.m_one in try let bnd, expl, large = func i in Some (bnd, if large then Q.zero else q), expl with I.No_finite_bound -> None, Explanation.empty let same_bnds _old _new = match _old, _new with | None, None -> true | None, Some _ | Some _, None -> false | Some(s,t), Some(u, v) -> Q.equal s u && Q.equal t v let add_if_better p _old _new simplex = (* p is in normal form pos *) let old_mn, old_mn_ex = extract_bound _old true in let old_mx, old_mx_ex = extract_bound _old false in let new_mn, new_mn_ex = extract_bound _new true in let new_mx, new_mx_ex = extract_bound _new false in if same_bnds old_mn new_mn && same_bnds old_mx new_mx then simplex else let l, z = P.to_list p in assert (Q.sign z = 0); let simplex = match l with [] -> assert false | [c, x] -> assert (Q.is_one c); Sim.Assert.var simplex x new_mn new_mn_ex new_mx new_mx_ex | _ -> let l = List.rev_map (fun (c, x) -> x, c) l in Sim.Assert.poly simplex (Sim.Core.P.from_list l) (alien_of p) new_mn new_mn_ex new_mx new_mx_ex in (* we don't solve immediately. It may be expensive *) simplex let finite_non_point_dom info = match info.Sim.Core.mini, info.Sim.Core.maxi with | None, _ | _, None -> None | Some (a, b), Some(x,y) -> assert (Q.is_zero b); (*called on integers only *) assert (Q.is_zero y); let c = Q.compare a x in assert (c <= 0); (* because simplex says sat *) if c = 0 then None else Some (Q.sub x a) (* not used for the moment *) let case_split = let gen_cs x n s orig = if debug_fm () then fprintf fmt "[Sim_CS-%d] %a = %a of size %a@." orig X.print x Q.print n Q.print s; let ty = X.type_info x in let r1 = x in let r2 = alien_of (P.create [] n ty) in [LR.mkv_eq r1 r2, true, CS (Th_arith, s)] in let aux_1 uf x (info,_) acc = assert (X.type_info x == Ty.Tint); match finite_non_point_dom info with | Some s when (Sim.Core.equals_optimum info.Sim.Core.value info.Sim.Core.mini || Sim.Core.equals_optimum info.Sim.Core.value info.Sim.Core.maxi) && Uf.is_normalized uf x -> let v, _ = info.Sim.Core.value in assert (Q.is_int v); begin match acc with | Some (_,_,s') when Q.compare s' s <= 0 -> acc | _ -> Some (x,v, s) end | _ -> acc in let aux_2 env uf x (info,_) acc = let v, _ = info.Sim.Core.value in assert (X.type_info x == Ty.Tint); match finite_non_point_dom info with | Some s when Q.is_int v && Uf.is_normalized uf x -> let fnd1, cont1 = try true, I.contains (fst (MX0.find x env.monomes)) v with Not_found -> false, true in let fnd2, cont2 = try true, I.contains (MP0.find (poly_of x) env.polynomes) v with Not_found -> false, true in if (fnd1 || fnd2) && cont1 && cont2 then match acc with | Some (_,_,s') when Q.compare s' s <= 0 -> acc | _ -> Some (x,v, s) else acc | _ -> acc in fun env uf -> let int_sim = env.int_sim in assert (int_sim.Sim.Core.status == Sim.Core.SAT); let acc = Sim.Core.MX.fold (aux_1 uf) int_sim.Sim.Core.non_basic None in let acc = Sim.Core.MX.fold (aux_1 uf) int_sim.Sim.Core.basic acc in match acc with | Some (x, n, s) -> gen_cs x n s 1 (*!!!disable case-split that separates and interval into two parts*) | None -> let acc = Sim.Core.MX.fold (aux_2 env uf) int_sim.Sim.Core.non_basic None in let acc = Sim.Core.MX.fold (aux_2 env uf) int_sim.Sim.Core.basic acc in match acc with | Some (x, n, s) -> gen_cs x n s 2 | None -> [] end module MP = struct include MP0 let assert_normalized_poly p = assert (let p0, c0, d0 = P.normal_form_pos p in let b = Q.is_zero c0 && Q.is_one d0 in begin if not b then fprintf fmt "[IC.assert_normalized_poly] %a is not normalized@." P.print p end; b) let n_add p i old ({polynomes} as env) = (*NB: adding a new entry into the map is considered as an improvement*) assert_normalized_poly p; if I.is_strict_smaller i old || not (MP0.mem p polynomes) then let ty = P.type_info p in let polynomes = MP0.add p i polynomes in let improved_p = SP.add p env.improved_p in if ty == Ty.Tint then {env with polynomes; improved_p; int_sim = Sim_Wrap.add_if_better p old i env.int_sim} else {env with polynomes; improved_p; rat_sim = Sim_Wrap.add_if_better p old i env.rat_sim} else let () = assert (I.equal i old) in env (* find with normalized polys *) let n_find p mp = assert_normalized_poly p; MP0.find p mp (* shadow the functions find and add of MP with the ones below to force the use of n_find and n_add for normalized polys *) let find (_ : unit) (_ : unit) = assert false let add (_ : unit) (_ : unit) (_ : unit) = assert false end module MX = struct include MX0 let assert_is_alien x = assert ( let b = P.extract x == None in begin if not b then fprintf fmt "[IC.assert_is_alien] %a is not an alien@." X.print x end; b ) let n_add x ((i,_) as e) old ({monomes} as env) = (*NB: adding a new entry into the map is considered as an improvement*) assert_is_alien x; if I.is_strict_smaller i old || not (MX0.mem x monomes) then let ty = X.type_info x in let monomes = MX0.add x e monomes in let improved_x = SX.add x env.improved_x in if ty == Ty.Tint then {env with monomes; improved_x; int_sim = Sim_Wrap.add_if_better (poly_of x) old i env.int_sim} else {env with monomes; improved_x; rat_sim = Sim_Wrap.add_if_better (poly_of x) old i env.rat_sim} else let () = assert (I.equal i old) in (* because use_x may be updated*) {env with monomes = MX0.add x e monomes} (* find with real aliens *) let n_find x mp = assert_is_alien x; MX0.find x mp (* shadow the functions find and add of MX with the ones below to force the use of n_find and n_add for true aliens *) let find (_ : unit) (_ : unit) = assert false let add (_ : unit) (_ : unit) (_ : unit) = assert false end (* generic find for values that may be non-alien or non normalized polys *) let generic_find xp env = let is_mon = P.extract xp == None in try if not is_mon then raise Not_found; let i, use = MX.n_find xp env.monomes in i, use, is_mon with Not_found -> (* according to this implem, it means that we can find aliens in polys but not in monomes. FIX THIS => an interval of x in monomes and in polys may be differents !!! *) let p0 = poly_of xp in let p, c = P.separate_constant p0 in let p, c0, d = P.normal_form_pos p in assert (Q.sign d <> 0 && Q.sign c0 = 0); let ty = P.type_info p0 in let ip = try MP.n_find p env.polynomes with Not_found -> I.undefined ty in let ip = if Q.is_one d then ip else I.scale d ip in let ip = if Q.is_zero c then ip else I.add ip (I.point c ty Explanation.empty) in ip, SX.empty, is_mon (* generic add for values that may be non-alien or non normalized polys *) let generic_add x j use is_mon env = (* NB: adding an entry into the map is considered as an improvement *) let ty = X.type_info x in if is_mon then try MX.n_add x (j,use) (fst (MX.n_find x env.monomes)) env with Not_found -> MX.n_add x (j, use) (I.undefined ty) env else let p0 = poly_of x in let p, c = P.separate_constant p0 in let p, c0, d = P.normal_form_pos p in assert (Q.sign d <> 0 && Q.sign c0 = 0); let j = I.add j (I.point (Q.minus c) ty Explanation.empty) in let j = I.scale (Q.inv d) j in try MP.n_add p j (MP.n_find p env.polynomes) env with Not_found -> MP.n_add p j (I.undefined ty) env (*BISECT-IGNORE-BEGIN*) module Debug = struct let assume a expl = if debug_fm () then begin fprintf fmt "[fm] We assume: %a@." LR.print (LR.make a); fprintf fmt "explanations: %a@." Explanation.print expl end let print_use fmt use = SX.iter (fprintf fmt "%a, " X.print) use let env env = if debug_fm () then begin fprintf fmt "------------ FM: inequations-------------------------@."; MPL.iter (fun a {Oracle.ple0=p; is_le=is_le} -> fprintf fmt "%a%s0 | %a@." P.print p (if is_le then "<=" else "<") L.LT.print a )env.inequations; fprintf fmt "------------ FM: monomes ----------------------------@."; MX.iter (fun x (i, use) -> fprintf fmt "%a : %a |-use-> {%a}@." X.print x I.print i print_use use) env.monomes; fprintf fmt "------------ FM: polynomes---------------------------@."; MP.iter (fun p i -> fprintf fmt "%a : %a@." P.print p I.print i) env.polynomes; fprintf fmt "-----------------------------------------------------@." end let implied_equalities l = if debug_fm () then begin fprintf fmt "[fm] %d implied equalities@." (List.length l); List.iter (fun (ra, _, ex, _) -> fprintf fmt " %a %a@." LR.print (LR.make ra) Explanation.print ex) l end let case_split r1 r2 = if debug_fm () then fprintf fmt "[case-split] %a = %a@." X.print r1 X.print r2 let no_case_split s = if debug_fm () then fprintf fmt "[case-split] %s : nothing@." s let inconsistent_interval expl = if debug_fm () then fprintf fmt "interval inconsistent %a@." Explanation.print expl let added_inequation kind ineq = if debug_fm () then begin fprintf fmt "[fm] I derived the (%s) inequality: %a %s 0@." kind P.print ineq.Oracle.ple0 (if ineq.Oracle.is_le then "<=" else "<"); fprintf fmt "from the following combination:@."; Util.MI.iter (fun a (coef, ple0, is_le) -> fprintf fmt "\t%a * (%a %s 0) + @." Q.print coef P.print ple0 (if is_le then "<=" else "<") )ineq.Oracle.dep; fprintf fmt "\t0@.@." end let tighten_interval_modulo_eq p1 p2 i1 i2 b1 b2 j = if debug_fm () then begin fprintf fmt "@.[fm] tighten intervals modulo eq: %a = %a@." P.print p1 P.print p2; fprintf fmt " %a has interval %a@." P.print p1 I.print i1; fprintf fmt " %a has interval %a@." P.print p2 I.print i2; fprintf fmt " intersection is %a@." I.print j; if b1 then fprintf fmt " > improve interval of %a@.@." P.print p1; if b2 then fprintf fmt " > improve interval of %a@.@." P.print p2; if not b1 && not b2 then fprintf fmt " > no improvement@.@." end end (*BISECT-IGNORE-END*) let empty classes = { inequations = MPL.empty; monomes = MX.empty ; polynomes = MP.empty ; known_eqs = SX.empty ; improved_p = SP.empty ; improved_x = SX.empty ; classes = classes; size_splits = Q.one; new_uf = Uf.empty (); rat_sim = Sim.Solve.solve (Sim.Core.empty ~is_int:false ~check_invs:false ~debug:0); int_sim = Sim.Solve.solve (Sim.Core.empty ~is_int:true ~check_invs:false ~debug:0); } (*let up_improved env p oldi newi = if I.is_strict_smaller newi oldi then { env with improved = SP.add p env.improved } else env*) (** computes an interval for vars = x_1^n_1 * ..... * x_i^n_i (1) if some var is not in monomes, then return undefined (2) check that all vars are in monomes before doing interval ops **) let mult_bornes_vars vars env ty = try let l = List.rev_map (fun (y,n) -> let i, _, _ = generic_find y env in i, n ) vars in List.fold_left (fun ui (yi,n) -> I.mult ui (I.power n yi)) (I.point Q.one ty Explanation.empty) l with Not_found -> I.undefined ty (** computes the interval of a polynome from those of its monomes. The monomes are supposed to be already added in env **) let intervals_from_monomes ?(monomes_inited=true) env p = let pl, v = P.to_list p in List.fold_left (fun i (a, x) -> let i_x, _ = try MX.n_find x env.monomes with Not_found -> if monomes_inited then assert false; I.undefined (X.type_info x), SX.empty in I.add (I.scale a i_x) i ) (I.point v (P.type_info p) Explanation.empty) pl (* because, it's not sufficient to look in the interval that corresponds to the normalized form of p ... *) let cannot_be_equal_to_zero env p ip = try let z = alien_of (P.create [] Q.zero (P.type_info p)) in match X.solve (alien_of p) z with | [] -> Sig.No (* p is equal to zero *) | _ -> I.doesnt_contain_0 ip with Exception.Unsolvable -> Sig.Yes (Explanation.empty, env.classes) let rec init_monomes_of_poly are_eq env p use_p expl = List.fold_left (fun env (_, x) -> try let u, old_use_x = MX.n_find x env.monomes in MX.n_add x (u, SX.union old_use_x use_p) u env with Not_found -> update_monome are_eq expl use_p env x ) env (fst (P.to_list p)) and init_alien are_eq expl p (normal_p, c, d) ty use_x env = let env = init_monomes_of_poly are_eq env p use_x expl in let i = intervals_from_monomes env p in let i = try let old_i = MP.n_find normal_p env.polynomes in let old_i = I.scale d (I.add old_i (I.point c ty Explanation.empty)) in I.intersect i old_i with Not_found -> i in env, i and update_monome are_eq expl use_x env x = let ty = X.type_info x in let ui, env = match X.ac_extract x with | Some {h=h; l=l } when Symbols.equal h (Symbols.Op Symbols.Mult) -> let use_x = SX.singleton x in let env = List.fold_left (fun env (r,_) -> let rp, _, _ = poly_of r |> P.normal_form_pos in match P.is_monomial rp with | Some (a,y,b) when Q.equal a Q.one && Q.sign b = 0 -> update_monome are_eq expl use_x env y | _ -> env (* should update polys ? *) ) env l in let m = mult_bornes_vars l env ty in m, env | _ -> match X.term_extract x with | Some t, _ -> let use_x = SX.singleton x in begin match Term.view t with | {Term.f = (Sy.Op Sy.Div); xs = [a; b]} -> let ra, ea = let (ra, _) as e = Uf.find env.new_uf a in if List.filter (X.equal x) (X.leaves ra) == [] then e else fst (X.make a), Explanation.empty (*otherwise, we loop*) in let rb, eb = let (rb, _) as e = Uf.find env.new_uf b in if List.filter (X.equal x) (X.leaves rb) == [] then e else fst (X.make b), Explanation.empty (*otherwise, we loop*) in let expl = Explanation.union expl (Explanation.union ea eb) in let pa = poly_of ra in let pb = poly_of rb in let (pa', ca, da) as npa = P.normal_form_pos pa in let (pb', cb, db) as npb = P.normal_form_pos pb in let env, ia = init_alien are_eq expl pa npa ty use_x env in let ia = I.add_explanation ia ea in (* take repr into account*) let env, ib = init_alien are_eq expl pb npb ty use_x env in let ib = I.add_explanation ib eb in (* take repr into account*) let ia, ib = match cannot_be_equal_to_zero env pb ib with | Yes (ex, _) when Q.equal ca cb && P.compare pa' pb' = 0 -> let expl = Explanation.union ex expl in I.point da ty expl, I.point db ty expl | Yes (ex, _) -> begin match are_eq a b with | Yes (ex_eq, _) -> let expl = Explanation.union ex expl in let expl = Explanation.union ex_eq expl in I.point Q.one ty expl, I.point Q.one ty expl | No -> ia, ib end | No -> ia, ib in I.div ia ib, env | _ -> I.undefined ty, env end | _ -> I.undefined ty, env in let u, use_x' = try MX.n_find x env.monomes with Not_found -> I.undefined (X.type_info x), use_x in let ui = I.intersect ui u in MX.n_add x (ui, (SX.union use_x use_x')) u env let rec tighten_ac are_eq x env expl = let ty = X.type_info x in let u, use_x = try MX.n_find x env.monomes with Not_found -> I.undefined ty, SX.empty in try match X.ac_extract x with | Some {h=h;t=t;l=[x,n]} when Symbols.equal h (Symbols.Op Symbols.Mult) && n mod 2 = 0 -> let env = match P.extract x with | None -> begin (* identity *) let u = I.root n u in let (pu, use_px) = try MX.n_find x env.monomes (* we know that x is a monome *) with Not_found -> I.undefined ty, SX.empty in let u = I.intersect u pu in let env = MX.n_add x (u, use_px) pu env in tighten_non_lin are_eq x use_px env expl end | Some _ -> (* Do something else for polys and non normalized-monomes ? *) env in env | Some {h=h;t=t;l=[x,n]} when Symbols.equal h (Symbols.Op Symbols.Mult) && n > 2 -> let env = match P.extract x with | None -> begin let u = I.root n u in let pu, use_px = try MX.n_find x env.monomes (* we know that x is a monome *) with Not_found -> I.undefined ty, SX.empty in let u = I.intersect u pu in let env = MX.n_add x (u, use_px) pu env in tighten_non_lin are_eq x use_px env expl end | Some _ -> (* Do something else for polys and non normalized-monomes ? *) env in env | _ -> env with Q.Not_a_float -> env and tighten_div x env expl = env and tighten_non_lin are_eq x use_x env expl = let env' = tighten_ac are_eq x env expl in let env' = tighten_div x env' expl in (*let use_x = SX.union use1_x use2_x in*) (* let i, _ = MX.find x env.monomes in *) (*let env' = update_monome are_eq expl use_x env' x in too expensive*) SX.fold (fun x acc -> let _, use = MX.n_find x acc.monomes in (* this is non-lin mult *) (*if I.is_strict_smaller new_i i then*) update_monome are_eq expl use acc x (*else acc*)) use_x env' let update_monomes_from_poly p i env = let lp, _ = P.to_list p in let ty = P.type_info p in List.fold_left (fun env (a,x) -> let np = P.remove x p in let (np,c,d) = P.normal_form_pos np in try let inp = MP.n_find np env.polynomes in let new_ix = I.scale (Q.div Q.one a) (I.add i (I.scale (Q.minus d) (I.add inp (I.point c ty Explanation.empty)))) in let old_ix, ux = MX.n_find x env.monomes in let ix = I.intersect old_ix new_ix in MX.n_add x (ix, ux) old_ix env with Not_found -> env ) env lp let update_polynomes_intervals env = MP.fold (fun p ip env -> let new_i = intervals_from_monomes env p in let i = I.intersect new_i ip in if I.is_strict_smaller i ip then update_monomes_from_poly p i (MP.n_add p i ip env) else env ) env.polynomes env let update_non_lin_monomes_intervals are_eq env = MX.fold (fun x (_, use_x) env -> tighten_non_lin are_eq x use_x env Explanation.empty ) env.monomes env let find_one_eq x u = match I.is_point u with | Some (v, ex) when X.type_info x != Ty.Tint || Q.is_int v -> let eq = LR.mkv_eq x (alien_of (P.create [] v (X.type_info x))) in Some (eq, None, ex, Sig.Other) | _ -> None let find_eq eqs x u env = match find_one_eq x u with | None -> eqs | Some eq1 -> begin match X.ac_extract x with | Some {h = h; l = [y,n]} when Symbols.equal h (Symbols.Op Symbols.Mult) -> let neweqs = try let u, _, _ = generic_find y env in match find_one_eq y u with | None -> eq1::eqs | Some eq2 -> eq1::eq2::eqs with Not_found -> eq1::eqs in neweqs | _ -> eq1::eqs end type ineq_status = | Trivial_eq | Trivial_ineq of Q.t | Bottom | Monome of Q.t * P.r * Q.t | Other let ineq_status {Oracle.ple0 = p ; is_le = is_le} = match P.is_monomial p with Some (a, x, v) -> Monome (a, x, v) | None -> if P.is_empty p then let _, v = P.separate_constant p in let c = Q.sign v (* equiv. to compare v Q.zero *) in if c > 0 || (c >=0 && not is_le) then Bottom else if c = 0 && is_le then Trivial_eq else Trivial_ineq v else Other (*let ineqs_from_dep dep borne_inf is_le = List.map (fun {poly_orig = p; coef = c} -> let (m,v,ty) = P.mult_const minusone p in (* quelle valeur pour le ?????? *) { ple0 = {poly = (m, v +/ (Q.div borne_inf c), ty); le = is_le} ; dep = []} )dep*) let mk_equality p = let r1 = alien_of p in let r2 = alien_of (P.create [] Q.zero (P.type_info p)) in LR.mkv_eq r1 r2 let fm_equalities eqs { Oracle.ple0 = p; dep = dep; expl = ex } = Util.MI.fold (fun _ (_, p, _) eqs -> (mk_equality p, None, ex, Sig.Other) :: eqs ) dep eqs let update_intervals are_eq env eqs expl (a, x, v) is_le = let (u0, use_x0) as ixx = MX.n_find x env.monomes in let uints, use_x = match X.ac_extract x with | Some {h=h; l=l} when Symbols.equal h (Symbols.Op Symbols.Mult) -> let m = mult_bornes_vars l env (X.type_info x) in I.intersect m u0, use_x0 | _ -> ixx in let b = Q.div (Q.mult Q.m_one v) a in let u = if Q.sign a > 0 then I.new_borne_sup expl b is_le uints else I.new_borne_inf expl b is_le uints in let env = MX.n_add x (u, use_x) u0 env in let env = tighten_non_lin are_eq x use_x env expl in env, (find_eq eqs x u env) let update_ple0 are_eq env p0 is_le expl = if P.is_empty p0 then env else let ty = P.type_info p0 in let a, _ = P.choose p0 in let p, change = if Q.sign a < 0 then P.mult_const Q.m_one p0, true else p0, false in let p, c, _ = P.normal_form p in let c = Q.minus c in let u = if change then I.new_borne_inf expl c is_le (I.undefined ty) else I.new_borne_sup expl c is_le (I.undefined ty) in let u, pu = try (* p is in normal_form_pos because of the ite above *) let pu = MP.n_find p env.polynomes in let i = I.intersect u pu in i, pu with Not_found -> u, I.undefined ty in let env = if I.is_strict_smaller u pu then update_monomes_from_poly p u (MP.n_add p u pu env) else env in match P.to_list p0 with | [a,x], v -> fst(update_intervals are_eq env [] expl (a, x, v) is_le) | _ -> env let register_relationship c x pi expl (x_rels, p_rels) = let x_rels = let a = Q.minus c, expl in let s = Q.sign c in assert (s <> 0); let low, up = try MX0.find x x_rels with Not_found -> MP0.empty, MP0.empty in let v = if s < 0 then MP0.add pi a low, up (* low_bnd(pi) / (-c) is a low_bnd of x *) else low, MP0.add pi a up (* low_bnd(pi) / (-c) is an up_bnd of x *) in MX0.add x v x_rels in let p_rels = let p0, c0, d0 = P.normal_form_pos pi in let b = c, Q.minus c0, Q.minus d0, expl in let s = Q.sign d0 in assert (s <> 0); let low,up = try MP0.find p0 p_rels with Not_found -> MX0.empty, MX0.empty in let w = if s < 0 then (*low_bnd(c*x)/(-d0) + (-c0) is a low_bnd of p0*) MX0.add x b low, up else (*low_bnd(c*x)/(-d0) + (-c0) is an up_bnd of p0*) low, MX0.add x b up in MP0.add p0 w p_rels in x_rels, p_rels let add_inequations are_eq acc x_opt lin = List.fold_left (fun ((env, eqs, rels) as acc) ineq -> let expl = ineq.Oracle.expl in match ineq_status ineq with | Bottom -> Debug.added_inequation "Bottom" ineq; raise (Exception.Inconsistent (expl, env.classes)) | Trivial_eq -> Debug.added_inequation "Trivial_eq" ineq; env, fm_equalities eqs ineq, rels | Trivial_ineq c -> Debug.added_inequation "Trivial_ineq" ineq; let n, pp = Util.MI.fold (fun _ (_, p, is_le) ((n, pp) as acc) -> if is_le then acc else match pp with | Some _ -> n+1, None | None when n=0 -> 1, Some p | _ -> n+1, None) ineq.Oracle.dep (0,None) in let env = Util.MI.fold (fun _ (coef, p, is_le) env -> let ty = P.type_info p in let is_le = match pp with Some x -> P.compare x p = 0 | _ -> is_le && n=0 in let p' = P.sub (P.create [] (Q.div c coef) ty) p in update_ple0 are_eq env p' is_le expl ) ineq.Oracle.dep env in env, eqs, rels | Monome (a, x, v) -> Debug.added_inequation "Monome" ineq; let env, eqs = update_intervals are_eq env eqs expl (a, x, v) ineq.Oracle.is_le in env, eqs, rels | Other -> match x_opt with | None -> acc | Some x -> let ple0 = ineq.Oracle.ple0 in let c = try P.find x ple0 with Not_found -> assert false in let ple0 = P.remove x ple0 in env, eqs, register_relationship c x ple0 ineq.Oracle.expl rels ) acc lin let split_problem env ineqs aliens = let current_age = Oracle.current_age () in let l, all_lvs = List.fold_left (fun (acc, all_lvs) ({Oracle.ple0=p} as ineq) -> match ineq_status ineq with | Trivial_eq | Trivial_ineq _ -> (acc, all_lvs) | Bottom -> raise (Exception.Inconsistent (ineq.Oracle.expl, env.classes)) | _ -> let lvs = List.fold_left (fun acc e -> SX.add e acc) SX.empty (aliens p) in ([ineq], lvs) :: acc , SX.union lvs all_lvs )([], SX.empty) ineqs in let ll = SX.fold (fun x l -> let lx, l_nx = List.partition (fun (_,s) -> SX.mem x s) l in match lx with | [] -> assert false | e:: lx -> let elx = List.fold_left (fun (l, lvs) (l', lvs') -> List.rev_append l l', SX.union lvs lvs') e lx in elx :: l_nx ) all_lvs l in let ll = List.filter (fun (ineqs, _) -> List.exists (fun ineq -> Z.equal current_age ineq.Oracle.age) ineqs )ll in List.fast_sort (fun (a,_) (b,_) -> List.length a - List.length b) ll let is_normalized_poly uf p = let p = alien_of p in let rp, _ = Uf.find_r uf p in if X.equal p rp then true else begin fprintf fmt "%a <= 0 NOT normalized@." X.print p; fprintf fmt "It is equal to %a@." X.print rp; false end let better_upper_bound_from_intervals env p = let p0, c0, d0 = P.normal_form_pos p in assert (Q.is_zero c0); try let i = MP.n_find p0 env.polynomes in if Q.is_one d0 then I.borne_sup i else if Q.is_m_one d0 then let bi, ex, is_large = I.borne_inf i in Q.minus bi, ex, is_large else assert false with I.No_finite_bound | Not_found -> assert false (*env.polynomes is up to date w.r.t. ineqs *) let better_bound_from_intervals env ({Oracle.ple0; is_le; dep} as v) = let p, c = P.separate_constant ple0 in assert (not (P.is_empty p)); let cur_up_bnd = Q.minus c in let i_up_bnd, expl, is_large = better_upper_bound_from_intervals env p in let new_p = P.add_const (Q.minus i_up_bnd) p in let a = match Util.MI.bindings dep with [a,_] -> a | _ -> assert false in let cmp = Q.compare i_up_bnd cur_up_bnd in assert (cmp <= 0); if cmp = 0 then match is_le, is_large with | false, true -> assert false (* intervals are normalized wrt ineqs *) | false, false | true, true -> v (* no change *) | true , false -> (* better bound, Large ineq becomes Strict *) {v with Oracle.ple0 = new_p; expl = expl; is_le = false; dep = Util.MI.singleton a (Q.one, new_p, false)} else (* new bound is better. i.e. i_up_bnd < cur_up_bnd *) {v with Oracle.ple0 = new_p; expl = expl; is_le = is_large; dep = Util.MI.singleton a (Q.one, new_p, is_large)} let args_of p = List.rev_map snd (fst (P.to_list p)) let refine_x_bounds ix env rels is_low = MP.fold (fun p (m_cx, ineq_ex) ix -> try (* recall (construction of x_rels): -> is_low : low_bnd(pi) / (-c) is a low_bnd of x -> not is_low : low_bnd(pi) / (-c) is an up_bnd of x *) assert (is_low == (Q.sign m_cx > 0)); let ip, _, _ = generic_find (alien_of p) env in let b, ex_b, is_le = I.borne_inf ip in (* invariant, see above *) let b = Q.div b m_cx in let func = if is_low then I.new_borne_inf else I.new_borne_sup in func (Explanation.union ineq_ex ex_b) b is_le ix with I.No_finite_bound -> ix )rels ix let monomes_relational_deductions env x_rels = MX.fold (fun x (low, up) env -> let ix0, use_x = try MX.n_find x env.monomes with Not_found -> assert false in let ix = refine_x_bounds ix0 env low true in let ix = refine_x_bounds ix env up false in if I.is_strict_smaller ix ix0 then MX.n_add x (ix, use_x) ix0 env else env )x_rels env let refine_p_bounds ip p env rels is_low = MX.fold (fun x (cx, mc0, md0, ineq_ex) ip -> try (* recall (construction of p_rels): -> is_low : low_bnd(c*x) / (-d0) + (-c0) is a low_bnd of p0 -> not is_low : low_bnd(c*x) / (-d0) + (-c0) is an up_bnd of p0 where p = (p0 + c0) * d0 and c*x + p <= 0 *) assert (is_low == (Q.sign md0 > 0)); let ix,_ = try MX.n_find x env.monomes with Not_found -> raise Exit in let bx, ex_b, is_le = (if Q.sign cx > 0 then I.borne_inf else I.borne_sup) ix in (* this this the low_bnd of c*x, see above *) let b = Q.mult cx bx in let b = Q.add (Q.div b md0) mc0 in (* final bnd of p0 *) let func = if is_low then I.new_borne_inf else I.new_borne_sup in func (Explanation.union ineq_ex ex_b) b is_le ip with Exit | I.No_finite_bound -> ip )rels ip let polynomes_relational_deductions env p_rels = MP.fold (fun p0 (low, up) env -> (* p0 is in normal_form pos *) let xp = alien_of p0 in if not (MP.mem p0 env.polynomes || MX.mem xp env.monomes) then env else let ip0, use, is_mon = generic_find xp env in let ip = refine_p_bounds ip0 p0 env low true in let ip = refine_p_bounds ip p0 env up false in if I.is_strict_smaller ip ip0 then if is_mon then MX.n_add xp (ip, use) ip0 env else MP.n_add p0 ip ip0 env else env )p_rels env let fm uf are_eq env eqs = if debug_fm () then fprintf fmt "[fm] in fm/fm-simplex@."; Options.tool_req 4 "TR-Arith-Fm"; let ineqs = MPL.fold (fun k v acc -> assert (is_normalized_poly uf v.Oracle.ple0); (better_bound_from_intervals env v) :: acc ) env.inequations [] in (*let pbs = split_problem env ineqs (fun p -> P.leaves p) in*) let pbs = split_problem env ineqs args_of in let res = List.fold_left (fun (env, eqs) (ineqs, _) -> let mp = Oracle.MINEQS.add_to_map Oracle.MINEQS.empty ineqs in let env, eqs, (x_rels, p_rels) = Oracle.available add_inequations are_eq (env, eqs, (MX.empty, MP.empty)) mp in let env = monomes_relational_deductions env x_rels in let env = polynomes_relational_deductions env p_rels in env, eqs )(env, eqs) pbs in if debug_fm () then fprintf fmt "[fm] out fm/fm-simplex@."; res let is_num r = let ty = X.type_info r in ty == Ty.Tint || ty == Ty.Treal let add_disequality are_eq env eqs p expl = let ty = P.type_info p in match P.to_list p with | ([], v) -> if Q.sign v = 0 then raise (Exception.Inconsistent (expl, env.classes)); env, eqs | ([a, x], v) -> let b = Q.div (Q.minus v) a in let i1 = I.point b ty expl in let i2, use2 = try MX.n_find x env.monomes with Not_found -> I.undefined ty, SX.empty in let i = I.exclude i1 i2 in let env = MX.n_add x (i,use2) i2 env in let env = tighten_non_lin are_eq x use2 env expl in env, find_eq eqs x i env | _ -> let p, c, _ = P.normal_form_pos p in let i1 = I.point (Q.minus c) ty expl in let i2 = try MP.n_find p env.polynomes with Not_found -> I.undefined ty in let i = I.exclude i1 i2 in let env = if I.is_strict_smaller i i2 then update_monomes_from_poly p i (MP.n_add p i i2 env) else env in env, eqs let add_equality are_eq env eqs p expl = let ty = P.type_info p in match P.to_list p with | ([], v) -> if Q.sign v <> 0 then raise (Exception.Inconsistent (expl, env.classes)); env, eqs | ([a, x], v) -> let b = Q.div (Q.minus v) a in let i = I.point b ty expl in let i2, use = try MX.n_find x env.monomes with Not_found -> I.undefined ty, SX.empty in let i = I.intersect i i2 in let env = MX.n_add x (i, use) i2 env in let env = tighten_non_lin are_eq x use env expl in env, find_eq eqs x i env | _ -> let p, c, _ = P.normal_form_pos p in let i = I.point (Q.minus c) ty expl in let i, ip = try let ip = MP.n_find p env.polynomes in I.intersect i ip, ip with Not_found -> i, I.undefined ty in let env = if I.is_strict_smaller i ip then update_monomes_from_poly p i (MP.n_add p i ip env) else env in let env = { env with known_eqs = SX.add (alien_of p) env.known_eqs } in env, eqs let normal_form a = match a with | L.Builtin (false, n, [r1; r2]) when is_le n && X.type_info r1 == Ty.Tint -> let pred_r1 = P.sub (poly_of r1) (P.create [] Q.one Ty.Tint) in LR.mkv_builtin true n [r2; alien_of pred_r1] | L.Builtin (true, n, [r1; r2]) when not (is_le n) && X.type_info r1 == Ty.Tint -> let pred_r2 = P.sub (poly_of r2) (P.create [] Q.one Ty.Tint) in LR.mkv_builtin true ale [r1; alien_of pred_r2] | L.Builtin (false, n, [r1; r2]) when is_le n -> LR.mkv_builtin true alt [r2; r1] | L.Builtin (false, n, [r1; r2]) when is_lt n -> LR.mkv_builtin true ale [r2; r1] | _ -> a let remove_trivial_eqs eqs la = let la = List.fold_left (fun m ((a, _, _, _) as e) -> MR.add a e m) MR.empty la in let eqs, _ = List.fold_left (fun ((eqs, m) as acc) ((sa, root, ex, orig) as e) -> if MR.mem sa m then acc else e :: eqs, MR.add sa e m )([], la) eqs in eqs let equalities_from_polynomes env eqs = let known, eqs = MP.fold (fun p i (knw, eqs) -> let xp = alien_of p in if SX.mem xp knw then knw, eqs else match I.is_point i with | Some (num, ex) -> let r2 = alien_of (P.create [] num (P.type_info p)) in SX.add xp knw, (LR.mkv_eq xp r2, None, ex, Sig.Other) :: eqs | None -> knw, eqs ) env.polynomes (env.known_eqs, eqs) in {env with known_eqs= known}, eqs let equalities_from_monomes env eqs = let known, eqs = MX.fold (fun x (i,_) (knw, eqs) -> if SX.mem x knw then knw, eqs else match I.is_point i with | Some (num, ex) -> let r2 = alien_of (P.create [] num (X.type_info x)) in SX.add x knw, (LR.mkv_eq x r2, None, ex, Sig.Other) :: eqs | None -> knw, eqs ) env.monomes (env.known_eqs, eqs) in {env with known_eqs= known}, eqs let equalities_from_intervals env eqs = let env, eqs = equalities_from_polynomes env eqs in equalities_from_monomes env eqs let count_splits env la = let nb = List.fold_left (fun nb (_,_,_,i) -> match i with | CS (Th_arith, n) -> Numbers.Q.mult nb n | _ -> nb )env.size_splits la in {env with size_splits = nb} let remove_ineq a ineqs = match a with None -> ineqs | Some a -> MPL.remove a ineqs let add_ineq a v ineqs = match a with None -> ineqs | Some a -> MPL.add a v ineqs (*** functions to improve intervals modulo equality ***) let tighten_eq_bounds env r1 r2 p1 p2 origin_eq expl = if P.is_const p1 != None || P.is_const p2 != None then env else match origin_eq with | CS _ | NCS _ -> env | Subst | Other -> (* Subst is needed, but is Other needed ?? or is it subsumed ? *) let i1, us1, is_mon_1 = generic_find r1 env in let i2, us2, is_mon_2 = generic_find r2 env in let j = I.add_explanation (I.intersect i1 i2) expl in let impr_i1 = I.is_strict_smaller j i1 in let impr_i2 = I.is_strict_smaller j i2 in Debug.tighten_interval_modulo_eq p1 p2 i1 i2 impr_i1 impr_i2 j; let env = if impr_i1 then generic_add r1 j us1 is_mon_1 env else env in if impr_i2 then generic_add r2 j us2 is_mon_2 env else env let rec loop_update_intervals are_eq env cpt = let cpt = cpt + 1 in let env = {env with improved_p=SP.empty; improved_x=SX.empty} in let env = update_non_lin_monomes_intervals are_eq env in let env = Sim_Wrap.solve env 1 in let env = update_polynomes_intervals env in let env = Sim_Wrap.solve env 1 in if env.improved_p == SP.empty && env.improved_x == SX.empty || cpt > 10 then env else loop_update_intervals are_eq env cpt let assume ~query env uf la = Oracle.incr_age (); let env = count_splits env la in let are_eq = Uf.are_equal uf ~added_terms:true in let classes = Uf.cl_extract uf in let env = {env with improved_p=SP.empty; improved_x=SX.empty; classes; new_uf = uf} in Debug.env env; let nb_num = ref 0 in let env, eqs, new_ineqs, to_remove = List.fold_left (fun ((env, eqs, new_ineqs, rm) as acc) (a, root, expl, orig) -> let a = normal_form a in Debug.assume a expl; try match a with | L.Builtin(_, n, [r1;r2]) when is_le n || is_lt n -> incr nb_num; let p1 = poly_of r1 in let p2 = poly_of r2 in let ineq = Oracle.create_ineq p1 p2 (is_le n) root expl in begin match ineq_status ineq with | Bottom -> raise (Exception.Inconsistent (expl, env.classes)) | Trivial_eq | Trivial_ineq _ -> {env with inequations=remove_ineq root env.inequations}, eqs, new_ineqs, (match root with None -> rm | Some a -> a:: rm) | Monome _ | Other -> let env = init_monomes_of_poly are_eq env ineq.Oracle.ple0 SX.empty Explanation.empty in let env = update_ple0 are_eq env ineq.Oracle.ple0 (is_le n) expl in {env with inequations=add_ineq root ineq env.inequations}, eqs, true, rm end | L.Distinct (false, [r1; r2]) when is_num r1 && is_num r2 -> incr nb_num; let p = P.sub (poly_of r1) (poly_of r2) in begin match P.is_const p with | Some c -> if Q.is_zero c then (* bottom *) raise (Exception.Inconsistent (expl, env.classes)) else (* trivial *) let rm = match root with Some a -> a::rm | None -> rm in env, eqs, new_ineqs, rm | None -> let env = init_monomes_of_poly are_eq env p SX.empty Explanation.empty in let env, eqs = add_disequality are_eq env eqs p expl in env, eqs, new_ineqs, rm end | L.Eq(r1, r2) when is_num r1 && is_num r2 -> incr nb_num; let p1 = poly_of r1 in let p2 = poly_of r2 in let p = P.sub p1 p2 in let env = init_monomes_of_poly are_eq env p SX.empty Explanation.empty in let env, eqs = add_equality are_eq env eqs p expl in let env = tighten_eq_bounds env r1 r2 p1 p2 orig expl in env, eqs, new_ineqs, rm | _ -> acc with I.NotConsistent expl -> Debug.inconsistent_interval expl ; raise (Exception.Inconsistent (expl, env.classes)) ) (env, [], false, []) la in try let env = if query then env else Sim_Wrap.solve env 1 in if !nb_num = 0 || query then env, {assume=[]; remove = to_remove} else (* we only call fm when new ineqs are assumed *) let env, eqs = if new_ineqs then fm uf are_eq env eqs else env, eqs in let env = Sim_Wrap.solve env 1 in let env = loop_update_intervals are_eq env 0 in let env, eqs = equalities_from_intervals env eqs in Debug.env env; let eqs = remove_trivial_eqs eqs la in Debug.implied_equalities eqs; let to_assume = List.rev_map (fun (sa, _, ex, orig) -> (LSem sa, ex, orig)) eqs in env, {assume = to_assume; remove = to_remove} with I.NotConsistent expl -> Debug.inconsistent_interval expl ; raise (Exception.Inconsistent (expl, env.classes)) let assume ~query env uf la = let env, res = assume ~query env uf la in let polys = MP.fold (fun p _ mp -> if Uf.is_normalized uf (alien_of p) then mp else MP.remove p mp) env.polynomes env.polynomes in {env with polynomes = polys}, res let query env uf a_ex = try ignore(assume ~query:true env uf [a_ex]); No with Exception.Inconsistent (expl, classes) -> Yes (expl, classes) let assume env uf la = if Options.timers() then try Options.exec_timer_start Timers.M_Arith Timers.F_assume; let res =assume ~query:false env uf la in Options.exec_timer_pause Timers.M_Arith Timers.F_assume; res with e -> Options.exec_timer_pause Timers.M_Arith Timers.F_assume; raise e else assume ~query:false env uf la let query env uf la = if Options.timers() then try Options.exec_timer_start Timers.M_Arith Timers.F_query; let res = query env uf la in Options.exec_timer_pause Timers.M_Arith Timers.F_query; res with e -> Options.exec_timer_pause Timers.M_Arith Timers.F_query; raise e else query env uf la let case_split_polynomes env = let o = MP.fold (fun p i o -> match I.finite_size i with | Some s when Q.compare s Q.one > 0 -> begin match o with | Some (s', p', _) when Q.compare s' s < 0 -> o | _ -> let n, ex, is_large = I.borne_inf i in assert (is_large); Some (s, p, n) end | _ -> o ) env.polynomes None in match o with | Some (s, p, n) -> let r1 = alien_of p in let r2 = alien_of (P.create [] n (P.type_info p)) in Debug.case_split r1 r2; [LR.mkv_eq r1 r2, true, CS (Th_arith, s)], s | None -> Debug.no_case_split "polynomes"; [], Q.zero let case_split_monomes env = let o = MX.fold (fun x (i,_) o -> match I.finite_size i with | Some s when Q.compare s Q.one > 0 -> begin match o with | Some (s', _, _) when Q.compare s' s < 0 -> o | _ -> let n, ex, is_large = I.borne_inf i in assert (is_large); Some (s, x, n) end | _ -> o ) env.monomes None in match o with | Some (s,x,n) -> let ty = X.type_info x in let r1 = x in let r2 = alien_of (P.create [] n ty) in Debug.case_split r1 r2; [LR.mkv_eq r1 r2, true, CS (Th_arith, s)], s | None -> Debug.no_case_split "monomes"; [], Q.zero let check_size for_model env res = if for_model then res else match res with | [] -> res | [_, _, CS (Th_arith, s)] -> if Numbers.Q.compare (Q.mult s env.size_splits) (max_split ()) <= 0 || Numbers.Q.sign (max_split ()) < 0 then res else [] | _ -> assert false let default_case_split env uf ~for_model = Options.tool_req 4 "TR-Arith-CaseSplit"; match check_size for_model env (Sim_Wrap.case_split env uf) with [] -> begin let cs1, sz1 = case_split_polynomes env in let cs2, sz2 = case_split_monomes env in match check_size for_model env cs1, check_size for_model env cs2 with | [], cs | cs, [] -> cs | cs1, cs2 -> if Q.compare sz1 sz2 < 0 then cs1 else cs2 end | res -> res let add = let are_eq t1 t2 = if Term.equal t1 t2 then Yes (Explanation.empty, []) else No in fun env new_uf r t -> try let env = {env with new_uf} in if is_num r then init_monomes_of_poly are_eq env (poly_of r) SX.empty Explanation.empty else env with I.NotConsistent expl -> Debug.inconsistent_interval expl ; raise (Exception.Inconsistent (expl, env.classes)) (* let extract_improved env = SP.fold (fun p acc -> MP.add p (MP.find p env.polynomes) acc) env.improved MP.empty *) let print_model fmt env rs = match rs with | [] -> () | _ -> fprintf fmt "Relation:"; List.iter (fun (t, r) -> let p = poly_of r in let ty = P.type_info p in if ty == Ty.Tint || ty == Ty.Treal then let p', c, d = P.normal_form_pos p in let pu' = try MP.n_find p' env.polynomes with Not_found -> I.undefined ty in let pm' = try intervals_from_monomes ~monomes_inited:false env p' with Not_found -> I.undefined ty in let u' = I.intersect pu' pm' in if I.is_point u' == None && I.is_undefined u' then let u = I.scale d (I.add u' (I.point c ty Explanation.empty)) in fprintf fmt "\n %a ∈ %a" Term.print t I.pretty_print u ) rs; fprintf fmt "\n@." let new_terms env = Term.Set.empty let case_split_union_of_intervals = let aux acc uf i z = if Uf.is_normalized uf z then match I.bounds_of i with | [] -> assert false | [_] -> () | (_,(v, ex))::_ -> acc := Some (z, v, ex); raise Exit in fun env uf -> let cs = ref None in try MP.iter (fun p i -> aux cs uf i (alien_of p)) env.polynomes; MX.iter (fun x (i,_) -> aux cs uf i x) env.monomes; [] with Exit -> match !cs with | None -> assert false | Some(_,None, _) -> assert false | Some(r1,Some (n, eps), ex) -> let ty = X.type_info r1 in let r2 = alien_of (P.create [] n ty) in let pred = if Q.is_zero eps then ale else (assert (Q.is_m_one eps); alt) in [LR.mkv_builtin true pred [r1; r2], true, CS (Th_arith, Q.one)] (*****) let int_constraints_from_map_intervals = let aux p xp i uf acc = if Uf.is_normalized uf xp && I.is_point i == None && P.type_info p == Ty.Tint then (p, I.bounds_of i) :: acc else acc in fun env uf -> let acc = MP.fold (fun p i acc -> aux p (alien_of p) i uf acc) env.polynomes [] in MX.fold (fun x (i,s) acc -> aux (poly_of x) x i uf acc) env.monomes acc let fm_simplex_unbounded_integers_encoding env uf = let simplex = Sim.Core.empty ~is_int:true ~check_invs:true ~debug:0 in let int_ctx = int_constraints_from_map_intervals env uf in List.fold_left (fun simplex (p, uints) -> match uints with | [] -> fprintf fmt "Intervals already empty !!!!@."; assert false | _::_::_ -> fprintf fmt "case-split over unions of intervals is needed !!!!@."; assert false | [(mn, ex_mn), (mx, ex_mx)] -> let l, c = P.to_list p in let l = List.rev_map (fun (c, x) -> x, c) (List.rev l) in assert (Q.sign c = 0); let cst0 = List.fold_left (fun z (x, c) -> Q.add z (Q.abs c))Q.zero l in let cst = Q.div cst0 (Q.from_int 2) in assert (mn == None || mx == None); let mn = match mn with | None -> None | Some (q, q') -> Some (Q.add q cst, q') in let mx = match mx with | None -> None | Some (q, q') -> Some (Q.sub q cst, q') in match l with | [] -> assert false | [x, c] -> assert (Q.is_one c); Sim.Assert.var simplex x mn ex_mn mx ex_mx | _ -> let xp = alien_of p in let sim_p = match Sim.Core.poly_of_slake simplex xp with | Some res -> res | None -> Sim.Core.P.from_list l in Sim.Assert.poly simplex sim_p xp mn ex_mn mx ex_mx ) simplex int_ctx let round_to_integers list = List.rev_map (fun (x, q1) -> let f = Q.floor q1 in let c = Q.ceiling q1 in x, if Q.compare (Q.sub q1 f) (Q.sub c q1) > 0 then f else c ) (List.rev list) (* cannot replace directly with env.int_sim because of encoding *) let model_from_simplex sim is_int env uf = match Sim.Result.get None sim with | Sim.Core.Unknown | Sim.Core.Unbounded _ | Sim.Core.Max _ -> assert false | Sim.Core.Unsat ex -> (* when splitting on union of intervals, FM does not include related ineqs when crossing. So, we may miss some bounds/deductions, and FM-Simplex may fail to find a model *) raise (Exception.Inconsistent(Lazy.force ex, env.classes)) | Sim.Core.Sat sol -> let {Sim.Core.main_vars; slake_vars; int_sol} = Lazy.force sol in let main_vars, slake_vars = if int_sol || not is_int then main_vars, slake_vars else round_to_integers main_vars, round_to_integers slake_vars in let fct = if is_int then Term.int else Term.real in List.fold_left (fun acc (v, q) -> assert (not is_int || Q.is_int q); if SX.mem v env.known_eqs || not (Uf.is_normalized uf v) then (* may happen because of incremental simplex on rationals *) acc else let t = fct (Q.to_string q) in let r, _ = X.make t in if debug_interpretation() then fprintf fmt "[%s simplex] %a = %a@." (if is_int then "integer" else "rational") X.print v X.print r; (v, r, Explanation.empty) :: acc )[] (List.rev main_vars) let model_from_unbounded_domains = let mk_cs acc (x, v, ex) = ((LR.view (LR.mk_eq x v)), true, CS (Th_arith, Q.from_int 2)) :: acc in fun env uf -> assert (env.int_sim.Sim.Core.status == Sim.Core.SAT); assert (env.rat_sim.Sim.Core.status == Sim.Core.SAT); let rat_sim = env.rat_sim in (* reuse existing rat_sim *) let int_sim = (* create a new int_sim with FM-Simplex encoding *) let sim = fm_simplex_unbounded_integers_encoding env uf in Sim.Solve.solve sim in let l1 = model_from_simplex rat_sim false env uf in let l2 = model_from_simplex int_sim true env uf in List.fold_left mk_cs (List.fold_left mk_cs [] l1) l2 let case_split env uf ~for_model = let res = default_case_split env uf for_model in match res with | [] -> if not for_model then [] else begin match case_split_union_of_intervals env uf with | [] -> model_from_unbounded_domains env uf | l -> l end | _ -> res end alt-ergo-1.30/src/theories/uf.ml0000644000175000001440000011001713014515065015070 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Exception open Sig module type S = sig type t type r val empty : unit -> t val add : t -> Term.t -> t * Literal.LT.t list val mem : t -> Term.t -> bool val find : t -> Term.t -> r * Explanation.t val find_r : t -> r -> r * Explanation.t val union : t -> r -> r -> Explanation.t -> t * (r * (r * r * Explanation.t) list * r) list val distinct : t -> r list -> Explanation.t -> t val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val already_distinct : t -> r list -> bool val class_of : t -> Term.t -> Term.t list val cl_extract : t -> Term.Set.t list val model : t -> (r * Term.t list * (Term.t * r) list) list * (Term.t list) list val print : Format.formatter -> t -> unit val term_repr : t -> Term.t -> Term.t val make : t -> Term.t -> r val is_normalized : t -> r -> bool val assign_next : t -> (r Literal.view * bool * Sig.lit_origin) list * t val output_concrete_model : t -> unit end module Make (X : Sig.X) : S with type r = X.r = struct module Ac = Ac.Make(X) module Ex = Explanation module Sy = Symbols module T = Term module MapT = Term.Map module SetT = Term.Set module LX = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) module MapL = Emap.Make(LX) module MapX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) module SetX = Set.Make(struct type t = X.r let compare = X.hash_cmp end) module SetXX = Set.Make(struct type t = X.r * X.r let compare (r1, r1') (r2, r2') = let c = X.hash_cmp r1 r2 in if c <> 0 then c else X.hash_cmp r1' r2' end) module SetAc = Set.Make(struct type t = Ac.t let compare = Ac.compare end) module SetRL = Set.Make (struct type t = Ac.t * X.r * Ex.t let compare (ac1,_,_) (ac2,_,_)= Ac.compare ac1 ac2 end) module RS = struct include Map.Make(struct type t = Sy.t let compare = Sy.compare end) let find k m = try find k m with Not_found -> SetRL.empty let add_rule (({h=h},_,_) as rul) mp = add h (SetRL.add rul (find h mp)) mp let remove_rule (({h=h},_,_) as rul) mp = add h (SetRL.remove rul (find h mp)) mp end type r = X.r type t = { (* term -> [t] *) make : r MapT.t; (* representative table *) repr : (r * Ex.t) MapX.t; (* r -> class (of terms) *) classes : SetT.t MapX.t; (*associates each value r with the set of semantical values whose representatives contains r *) gamma : SetX.t MapX.t; (* the disequations map *) neqs: Ex.t MapL.t MapX.t; (*AC rewrite system *) ac_rs : SetRL.t RS.t; } exception Found_term of T.t (* hack: would need an inverse map from semantic values to terms *) let terms_of_distinct env l = match LX.view l with | Literal.Distinct (false, rl) -> let lt = List.fold_left (fun acc r -> try let cl = MapX.find r env.classes in SetT.iter (fun t -> if X.equal (MapT.find t env.make) r then raise (Found_term t)) cl; acc with | Found_term t -> t :: acc | Not_found -> acc) [] rl in let rec distrib = function | x :: r -> (distrib r) @ (List.map (fun y -> SetT.add x (SetT.singleton y)) r) | [] -> [] in distrib lt | _ -> assert false let cl_extract env = if bottom_classes () then let classes = MapX.fold (fun _ cl acc -> cl :: acc) env.classes [] in MapX.fold (fun _ ml acc -> MapL.fold (fun l _ acc -> (terms_of_distinct env l) @ acc) ml acc ) env.neqs classes else [] (*BISECT-IGNORE-BEGIN*) module Debug = struct let rs_print fmt = SetX.iter (fprintf fmt "\t%a@." X.print) let lm_print fmt = MapL.iter (fun k dep -> fprintf fmt "%a %a" LX.print k Ex.print dep) let t_print fmt = SetT.iter (fprintf fmt "%a " T.print) let pmake fmt m = fprintf fmt "[.] map:\n"; MapT.iter (fun t r -> fprintf fmt "%a -> %a\n" T.print t X.print r) m let prepr fmt m = fprintf fmt "------------- UF: Representatives map ----------------@."; MapX.iter (fun r (rr,dep) -> fprintf fmt "%a --> %a %a\n" X.print r X.print rr Ex.print dep) m let prules fmt s = fprintf fmt "------------- UF: AC rewrite rules ----------------------@."; RS.iter (fun k srl -> SetRL.iter (fun (ac,d,dep)-> fprintf fmt "%a ~~> %a %a\n" X.print (X.ac_embed ac) X.print d Ex.print dep )srl )s let pclasses fmt m = fprintf fmt "------------- UF: Class map --------------------------@."; MapX.iter (fun k s -> fprintf fmt "%a -> %a\n" X.print k Term.print_list (SetT.elements s)) m let pgamma fmt m = fprintf fmt "------------- UF: Gamma map --------------------------@."; MapX.iter (fun k s -> fprintf fmt "%a -> \n%a" X.print k rs_print s) m let pneqs fmt m = fprintf fmt "------------- UF: Disequations map--------------------@."; MapX.iter (fun k s -> fprintf fmt "%a -> %a\n" X.print k lm_print s) m let all fmt env = if debug_uf () then begin fprintf fmt "-------------------------------------------------@."; fprintf fmt "%a %a %a %a %a" pmake env.make prepr env.repr prules env.ac_rs pclasses env.classes pneqs env.neqs; fprintf fmt "-------------------------------------------------@." end let lookup_not_found t env = fprintf fmt "Uf: %a Not_found in env@." T.print t; all fmt env let canon_of r rr = if rewriting () && verbose () then fprintf fmt "canon %a = %a@." X.print r X.print rr let init_leaf p = if debug_uf () then fprintf fmt "init_leaf: %a@." X.print p let critical_pair rx ry = if debug_uf () then fprintf fmt "[uf] critical pair: %a = %a@." X.print rx X.print ry let collapse_mult g2 d2 = if debug_ac () then fprintf fmt "[uf] collapse *: %a = %a@." X.print g2 X.print d2 let collapse g2 d2 = if debug_ac () then fprintf fmt "[uf] collapse: %a = %a@." X.print g2 X.print d2 let compose p v g d = if debug_ac () then Format.eprintf "Compose : %a -> %a on %a and %a@." X.print p X.print v Ac.print g X.print d let x_solve rr1 rr2 dep = if debug_uf () then printf "[uf] x-solve: %a = %a %a@." X.print rr1 X.print rr2 Ex.print dep let ac_solve p v dep = if debug_uf () then printf "[uf] ac-solve: %a |-> %a %a@." X.print p X.print v Ex.print dep let ac_x r1 r2 = if debug_uf () then printf "[uf] ac(x): delta (%a) = delta (%a)@." X.print r1 X.print r2 let distinct d = if debug_uf () then fprintf fmt "[uf] distinct %a@." LX.print d let are_distinct t1 t2 = if debug_uf () then printf " [uf] are_distinct %a %a @." T.print t1 T.print t2 end (*BISECT-IGNORE-END*) module Env = struct let mem env t = MapT.mem t env.make let lookup_by_t t env = Options.exec_thread_yield (); try MapX.find (MapT.find t env.make) env.repr with Not_found -> Debug.lookup_not_found t env; assert false (*X.make t, Ex.empty*) (* XXXX *) let lookup_by_t___without_failure t env = try MapX.find (MapT.find t env.make) env.repr with Not_found -> fst (X.make t), Ex.empty let lookup_by_r r env = Options.exec_thread_yield (); try MapX.find r env.repr with Not_found -> r, Ex.empty let disjoint_union l_1 l_2 = let rec di_un (l1,c,l2) (l_1,l_2)= Options.exec_thread_yield (); match l_1,l_2 with | [],[] -> l1, c, l2 | l, [] -> di_un (l @ l1,c,l2) ([],[]) | [], l -> di_un (l1,c,l @ l2) ([],[]) | (a,m)::r, (b,n)::s -> let cmp = X.str_cmp a b in if cmp = 0 then if m = n then di_un (l1,(a,m)::c,l2) (r,s) else if m > n then di_un ((a,m-n)::l1,(a,n)::c,l2) (r,s) else di_un (l1,(b,n)::c,(b,n-m)::l2) (r,s) else if cmp > 0 then di_un ((a,m)::l1,c,l2) (r,(b,n)::s) else di_un (l1,c,(b,n)::l2) ((a,m)::r,s) in di_un ([],[],[]) (l_1,l_2) (* Debut : Code pour la mise en forme normale modulo env *) exception List_minus_exn let list_minus l_1 l_2 = let rec di_un l1 l_1 l_2 = match l_1, l_2 with [],[] -> l1 | l, [] -> l @ l1 | [], l -> raise List_minus_exn | (a,m)::r, (b,n)::s -> let cmp = X.str_cmp a b in if cmp = 0 then if m = n then di_un l1 r s else if m > n then di_un ((a,m-n)::l1) r s else raise List_minus_exn else if cmp > 0 then di_un ((a,m)::l1) r ((b,n)::s) else raise List_minus_exn in di_un [] l_1 l_2 let apply_rs r rls = let fp = ref true in let r = ref r in let ex = ref Ex.empty in let rec apply_rule ((p, v, dep) as rul) = let c = Ac.compare !r p in if c = 0 then begin r := {!r with l=[v, 1]}; ex := Ex.union !ex dep end else if c < 0 then raise Exit else try r := {!r with l = Ac.add !r.h (v, 1) (list_minus !r.l p.l)}; ex := Ex.union !ex dep; fp := false; apply_rule rul with List_minus_exn -> () in let rec fixpoint () = Options.exec_thread_yield (); (try SetRL.iter apply_rule rls with Exit -> ()); if !fp then !r, !ex else (fp := true; fixpoint ()) in fixpoint() let filter_leaves r = List.fold_left (fun (p,q) r -> match X.ac_extract r with | None -> SetX.add r p, q | Some ac -> p, SetAc.add ac q )(SetX.empty,SetAc.empty) (X.leaves r) let canon_empty st env = SetX.fold (fun p ((z, ex) as acc) -> let q, ex_q = lookup_by_r p env in if X.equal p q then acc else (p,q)::z, Ex.union ex_q ex) st ([], Ex.empty) let canon_ac st env = SetAc.fold (fun ac (z,ex) -> let rac, ex_ac = apply_rs ac (RS.find ac.h env.ac_rs) in if Ac.compare ac rac = 0 then z, ex else (X.color ac, X.color rac) :: z, Ex.union ex ex_ac) st ([], Ex.empty) let canon_aux rx = List.fold_left (fun r (p,v) -> X.subst p v r) rx let rec canon env r ex_r = let se, sac = filter_leaves r in let subst, ex_subst = canon_empty se env in let subst_ac, ex_ac = canon_ac sac env in (* explications? *) let r2 = canon_aux (canon_aux r subst_ac) subst in let ex_r2 = Ex.union (Ex.union ex_r ex_subst) ex_ac in if X.equal r r2 then r2, ex_r2 else canon env r2 ex_r2 let normal_form env r = let rr, ex = canon env r Ex.empty in Debug.canon_of r rr; rr,ex (* Fin : Code pour la mise en forme normale modulo env *) let find_or_normal_form env r = Options.exec_thread_yield (); try MapX.find r env.repr with Not_found -> normal_form env r let lookup_for_neqs env r = Options.exec_thread_yield (); try MapX.find r env.neqs with Not_found -> MapL.empty let add_to_classes t r classes = MapX.add r (SetT.add t (try MapX.find r classes with Not_found -> SetT.empty)) classes let update_classes c nc classes = let s1 = try MapX.find c classes with Not_found -> SetT.empty in let s2 = try MapX.find nc classes with Not_found -> SetT.empty in MapX.add nc (SetT.union s1 s2) (MapX.remove c classes) let add_to_gamma r c gamma = Options.exec_thread_yield (); List.fold_left (fun gamma x -> let s = try MapX.find x gamma with Not_found -> SetX.empty in MapX.add x (SetX.add r s) gamma) gamma (X.leaves c) let explain_repr_of_distinct dep lit env = let l = match LX.view lit with | Literal.Distinct (false, ([_;_] as args)) -> args | Literal.Pred (r, _) -> [r] | Literal.Distinct (false, _) -> failwith "TODO: only take equal args repr" | _ -> assert false in List.fold_left (fun dep r -> Ex.union dep (snd (find_or_normal_form env r))) dep l (* r1 = r2 => neqs(r1) \uplus neqs(r2) *) let update_neqs r1 r2 dep env = let merge_disjoint_maps l1 ex1 mapl = try let ex2 = MapL.find l1 mapl in Options.tool_req 3 "TR-CCX-Congruence-Conflict"; let ex = Ex.union (Ex.union ex1 ex2) dep in let ex = explain_repr_of_distinct ex l1 env in raise (Inconsistent (ex, cl_extract env)) with Not_found -> (* with the use of explain_repr_of_distinct above, I don't need to propagate dep to ex1 here *) MapL.add l1 ex1 mapl in let nq_r1 = lookup_for_neqs env r1 in let nq_r2 = lookup_for_neqs env r2 in let small, big = if MapL.height nq_r1 < MapL.height nq_r2 then nq_r1, nq_r2 else nq_r2, nq_r1 in let mapl = MapL.fold merge_disjoint_maps small big in MapX.add r2 mapl (MapX.add r1 mapl env.neqs) let init_leaf env p = Debug.init_leaf p; let in_repr = MapX.mem p env.repr in let mk_env = env.make in let make = match X.term_extract p with | Some t, true when not (MapT.mem t mk_env) -> MapT.add t p mk_env | _ -> mk_env in { env with make = make; repr = if in_repr then env.repr else MapX.add p (p, Ex.empty) env.repr; classes = if MapX.mem p env.classes then env.classes else update_classes p p env.classes; gamma = if in_repr then env.gamma else add_to_gamma p p env.gamma ; neqs = if MapX.mem p env.neqs then env.neqs else update_neqs p p Ex.empty env } let init_leaves env v = let env = init_leaf env v in List.fold_left init_leaf env (X.leaves v) let init_new_ac_leaves env mkr = List.fold_left (fun env x -> match X.ac_extract x with | None -> env | Some _ -> if MapX.mem x env.repr then env else init_leaves env x ) env (X.leaves mkr) let init_term env t = let mkr, ctx = X.make t in let rp, ex = normal_form env mkr in let env = {env with make = MapT.add t mkr env.make; repr = MapX.add mkr (rp,ex) env.repr; classes = add_to_classes t rp env.classes; gamma = add_to_gamma mkr rp env.gamma; neqs = if MapX.mem rp env.neqs then env.neqs (* pourquoi ce test *) else MapX.add rp MapL.empty env.neqs} in (init_new_ac_leaves env mkr), ctx let head_cp eqs env pac ({h=h} as ac) v dep = try (*if RS.mem h env.ac_rs then*) SetRL.iter (fun (g, d, dep_rl) -> if X.equal pac (X.ac_embed g) && X.equal v d then () else match disjoint_union ac.l g.l with | _ , [] , _ -> () | l1 , cm , l2 -> let rx = X.color {ac with l = Ac.add h (d,1) l1} in let ry = X.color {g with l = Ac.add h (v,1) l2} in Debug.critical_pair rx ry; if not (X.equal rx ry) then Queue.push (rx, ry, Ex.union dep dep_rl) eqs) (RS.find h env.ac_rs) with Not_found -> assert false let comp_collapse eqs env (p, v, dep) = RS.fold (fun h rls env -> SetRL.fold (fun ((g, d, dep_rl) as rul) env -> Options.exec_thread_yield (); let env = {env with ac_rs = RS.remove_rule rul env.ac_rs} in let gx = X.color g in let g2, ex_g2 = normal_form env (Ac.subst p v g) in let d2, ex_d2 = normal_form env (X.subst p v d) in if X.str_cmp g2 d2 <= 0 then begin Debug.collapse_mult g2 d2; let ex = Ex.union (Ex.union ex_g2 ex_d2) (Ex.union dep_rl dep) in Queue.push (g2, d2, ex) eqs; env end else if X.equal g2 gx then (* compose *) begin Debug.compose p v g d; let ex = Ex.union ex_d2 (Ex.union dep_rl dep) in {env with ac_rs = RS.add_rule (g,d2, ex) env.ac_rs} end else (* collapse *) begin Debug.collapse g2 d2; let ex = Ex.union (Ex.union ex_g2 ex_d2) (Ex.union dep_rl dep) in Queue.push (g2, d2, ex) eqs; env end ) rls env ) env.ac_rs env (* TODO explications: ajout de dep dans ac_rs *) let apply_sigma_ac eqs env ((p, v, dep) as sigma) = match X.ac_extract p with | None -> comp_collapse eqs env sigma | Some r -> let env = {env with ac_rs = RS.add_rule (r, v, dep) env.ac_rs} in let env = comp_collapse eqs env sigma in head_cp eqs env p r v dep; env let update_aux dep set env= SetXX.fold (fun (rr, nrr) env -> { env with neqs = update_neqs rr nrr dep env ; classes = update_classes rr nrr env.classes}) set env (* Patch modudo AC for CC: if p is a leaf different from r and r is AC and reduced by p, then r --> nrr should be added as a PIVOT, not just as TOUCHED by p |-> ... This is required for a correct update of USE *) let update_global_tch global_tch p r nrr ex = if X.equal p r then global_tch else match X.ac_extract r with | None -> global_tch | Some _ -> (r, [r, nrr, ex], nrr) :: global_tch let apply_sigma_uf env (p, v, dep) global_tch = assert (MapX.mem p env.gamma); let use_p = MapX.find p env.gamma in try let env, touched_p, global_tch, neqs_to_up = SetX.fold (fun r ((env, touched_p, global_tch, neqs_to_up) as acc) -> Options.exec_thread_yield (); let rr, ex = MapX.find r env.repr in let nrr = X.subst p v rr in if X.equal rr nrr then acc else let ex = Ex.union ex dep in let env = {env with repr = MapX.add r (nrr, ex) env .repr; gamma = add_to_gamma r nrr env.gamma } in env, (r, nrr, ex)::touched_p, update_global_tch global_tch p r nrr ex, SetXX.add (rr, nrr) neqs_to_up ) use_p (env, [], global_tch, SetXX.empty) in (* Correction : Do not update neqs twice for the same r *) update_aux dep neqs_to_up env, touched_p, global_tch with Not_found -> assert false let up_uf_rs dep env tch = if RS.is_empty env.ac_rs then env, tch else let env, tch, neqs_to_up = MapX.fold (fun r (rr,ex) ((env, tch, neqs_to_up) as acc) -> Options.exec_thread_yield (); let nrr, ex_nrr = normal_form env rr in if X.equal nrr rr then acc else let ex = Ex.union ex ex_nrr in let env = {env with repr = MapX.add r (nrr, ex) env.repr; gamma = add_to_gamma r nrr env.gamma } in let tch = if X.is_a_leaf r then (r,[r, nrr, ex],nrr) :: tch else tch in env, tch, SetXX.add (rr, nrr) neqs_to_up ) env.repr (env, tch, SetXX.empty) in (* Correction : Do not update neqs twice for the same r *) update_aux dep neqs_to_up env, tch let apply_sigma eqs env tch ((p, v, dep) as sigma) = let env = init_leaves env p in let env = init_leaves env v in let env = apply_sigma_ac eqs env sigma in let env, touched_sigma, tch = apply_sigma_uf env sigma tch in up_uf_rs dep env ((p, touched_sigma, v) :: tch) end let add env t = Options.tool_req 3 "TR-UFX-Add"; if MapT.mem t env.make then env, [] else Env.init_term env t let ac_solve eqs dep (env, tch) (p, v) = (* pourquoi recuperer le representant de rv? r = rv d'apres testopt *) Debug.ac_solve p v dep; assert (not (Options.enable_assertions()) || let rp, _ = Env.find_or_normal_form env p in X.equal p rp); let rv, ex_rv = Env.find_or_normal_form env v in assert (not (Options.enable_assertions()) || let rv, _ = Env.find_or_normal_form env v in X.equal v rv); let dep = Ex.union ex_rv dep in Env.apply_sigma eqs env tch (p, rv, dep) let x_solve env r1 r2 dep = let rr1, ex_r1 = Env.find_or_normal_form env r1 in let rr2, ex_r2 = Env.find_or_normal_form env r2 in let dep = Ex.union dep (Ex.union ex_r1 ex_r2) in Debug.x_solve rr1 rr2 dep; if X.equal rr1 rr2 then begin Options.tool_req 3 "TR-CCX-Remove"; [], dep (* Remove rule *) end else begin ignore (Env.update_neqs rr1 rr2 dep env); try X.solve rr1 rr2, dep with Unsolvable -> Options.tool_req 3 "TR-CCX-Congruence-Conflict"; raise (Inconsistent (dep, cl_extract env)) end let rec ac_x eqs env tch = if Queue.is_empty eqs then env, tch else let r1, r2, dep = Queue.pop eqs in Debug.ac_x r1 r2; let sbs, dep = x_solve env r1 r2 dep in let env, tch = List.fold_left (ac_solve eqs dep) (env, tch) sbs in if debug_uf () then Debug.all fmt env; ac_x eqs env tch let union env r1 r2 dep = Options.tool_req 3 "TR-UFX-Union"; let equations = Queue.create () in Queue.push (r1,r2, dep) equations; ac_x equations env [] let union env r1 r2 dep = if Options.timers() then try Options.exec_timer_start Timers.M_UF Timers.F_union; let res = union env r1 r2 dep in Options.exec_timer_pause Timers.M_UF Timers.F_union; res with e -> Options.exec_timer_pause Timers.M_UF Timers.F_union; raise e else union env r1 r2 dep let rec distinct env rl dep = Debug.all fmt env; let d = LX.mk_distinct false rl in Debug.distinct d; let env, _, newds = List.fold_left (fun (env, mapr, newds) r -> Options.exec_thread_yield (); let rr, ex = Env.find_or_normal_form env r in try let exr = MapX.find rr mapr in Options.tool_req 3 "TR-CCX-Distinct-Conflict"; raise (Inconsistent ((Ex.union ex exr), cl_extract env)) with Not_found -> let uex = Ex.union ex dep in let mdis = try MapX.find rr env.neqs with Not_found -> MapL.empty in let mdis = try MapL.add d (Ex.merge uex (MapL.find d mdis)) mdis with Not_found -> MapL.add d uex mdis in let env = Env.init_leaf env rr in let env = {env with neqs = MapX.add rr mdis env.neqs} in env, MapX.add rr uex mapr, (rr, ex, mapr)::newds ) (env, MapX.empty, []) rl in List.fold_left (fun env (r1, ex1, mapr) -> MapX.fold (fun r2 ex2 env -> let ex = Ex.union ex1 (Ex.union ex2 dep) in try match X.solve r1 r2 with | [a, b] -> if (X.equal a r1 && X.equal b r2) || (X.equal a r2 && X.equal b r1) then env else distinct env [a; b] ex | [] -> Options.tool_req 3 "TR-CCX-Distinct-Conflict"; raise (Inconsistent (ex, cl_extract env)) | _ -> env with Unsolvable -> env) mapr env) env newds let are_equal env t1 t2 ~added_terms = if Term.equal t1 t2 then Sig.Yes (Ex.empty, cl_extract env) else let lookup = if added_terms then Env.lookup_by_t else Env.lookup_by_t___without_failure in let r1, ex_r1 = lookup t1 env in let r2, ex_r2 = lookup t2 env in if X.equal r1 r2 then Yes (Ex.union ex_r1 ex_r2, cl_extract env) else No let are_distinct env t1 t2 = Debug.are_distinct t1 t2; let r1, ex_r1 = Env.lookup_by_t t1 env in let r2, ex_r2 = Env.lookup_by_t t2 env in try ignore (union env r1 r2 (Ex.union ex_r1 ex_r2)); No with Inconsistent (ex, classes) -> Yes (ex, classes) let already_distinct env lr = let d = LX.mk_distinct false lr in try List.iter (fun r -> let mdis = MapX.find r env.neqs in ignore (MapL.find d mdis) ) lr; true with Not_found -> false let mapt_choose m = let r = ref None in (try MapT.iter (fun x rx -> r := Some (x, rx); raise Exit ) m with Exit -> ()); match !r with Some b -> b | _ -> raise Not_found let model env = let eqs = MapX.fold (fun r cl acc -> let l, to_rel = List.fold_left (fun (l, to_rel) t -> let rt = MapT.find t env.make in if complete_model () || T.is_in_model t then if X.equal rt r then l, (t,rt)::to_rel else t::l, (t,rt)::to_rel else l, to_rel ) ([], []) (SetT.elements cl) in (r, l, to_rel)::acc ) env.classes [] in let rec extract_neqs acc makes = try let x, rx = mapt_choose makes in let makes = MapT.remove x makes in let acc = if complete_model () || T.is_in_model x then MapT.fold (fun y ry acc -> if (complete_model () || T.is_in_model y) && (already_distinct env [rx; ry] || already_distinct env [ry; rx]) then [y; x]::acc else acc ) makes acc else acc in extract_neqs acc makes with Not_found -> acc in let neqs = extract_neqs [] env.make in eqs, neqs let find env t = Options.tool_req 3 "TR-UFX-Find"; Env.lookup_by_t t env let find_r = Options.tool_req 3 "TR-UFX-Find"; Env.find_or_normal_form let print = Debug.all let mem = Env.mem let class_of env t = try let rt, _ = MapX.find (MapT.find t env.make) env.repr in MapX.find rt env.classes with Not_found -> SetT.singleton t let term_repr uf t = let st = class_of uf t in SetT.fold (fun s t -> let c = let c = (T.view t).T.depth - (T.view s).T.depth in if c <> 0 then c else T.compare s t in if c > 0 then s else t ) st t let class_of env t = SetT.elements (class_of env t) let empty () = let env = { make = MapT.empty; repr = MapX.empty; classes = MapX.empty; gamma = MapX.empty; neqs = MapX.empty; ac_rs = RS.empty } in let env, _ = add env Term.vrai in let env, _ = add env Term.faux in distinct env [X.top (); X.bot ()] Ex.empty let make uf t = MapT.find t uf.make (*** add wrappers to profile exported functions ***) let add env t = if Options.timers() then try Options.exec_timer_start Timers.M_UF Timers.F_add_terms; let res = add env t in Options.exec_timer_pause Timers.M_UF Timers.F_add_terms; res with e -> Options.exec_timer_pause Timers.M_UF Timers.F_add_terms; raise e else add env t let is_normalized env r = List.for_all (fun x -> try X.equal x (fst (MapX.find x env.repr)) with Not_found -> true) (X.leaves r) let distinct_from_constants rep env = let neqs = try MapX.find rep env.neqs with Not_found -> assert false in MapL.fold (fun lit _ acc -> let contains_rep = ref false in let lit_vals = match LX.view lit with | Literal.Distinct (_, l) -> l | _ -> [] in let acc2 = List.fold_left (fun acc r -> if X.equal rep r then contains_rep := true; match X.leaves r with | [] -> r::acc | _ -> acc )acc lit_vals in if !contains_rep then acc2 else acc )neqs [] let assign_next env = let acc = ref None in try MapX.iter (fun r eclass -> let eclass = try SetT.fold (fun t z -> (t, MapT.find t env.make)::z) eclass [] with Not_found -> assert false in let opt = X.assign_value r (distinct_from_constants r env) eclass in match opt with | None -> () | Some (s, is_cs) -> acc := Some (s, r, is_cs); raise Exit )env.classes; [], env (* no cs *) with Exit -> match !acc with | None -> assert false | Some (s, rep, is_cs) -> if Options.debug_interpretation() then fprintf fmt "TRY assign-next %a = %a@." X.print rep Term.print s; (* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! modify this to be able to returns CS on terms. This way, we will not modify env in this function !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *) let env, _ = add env s in (* important for termination *) let eq = LX.view (LX.mk_eq rep (make env s)) in [eq, is_cs, Sig.CS (Sig.Th_UF, Numbers.Q.one)], env module Profile = struct module P = Map.Make (struct type t = Sy.t * Ty.t list * Ty.t let (|||) c1 c2 = if c1 <> 0 then c1 else c2 let compare (a1, b1, c1) (a2, b2, c2) = let l1_l2 = List.length b1 - List.length b2 in let c = l1_l2 ||| (Ty.compare c1 c2) ||| (Sy.compare a1 a2) in if c <> 0 then c else let c = ref 0 in try List.iter2 (fun ty1 ty2 -> let d = Ty.compare ty1 ty2 in if d <> 0 then begin c := d; raise Exit end ) b1 b2; 0 with | Exit -> assert (!c <> 0); !c | Invalid_argument _ -> assert false end) module V = Set.Make (struct type t = (T.t * (X.r * string)) list * (X.r * string) let compare (l1, (v1,_)) (l2, (v2,_)) = let c = X.hash_cmp v1 v2 in if c <> 0 then c else let c = ref 0 in try List.iter2 (fun (_,(x,_)) (_,(y,_)) -> let d = X.hash_cmp x y in if d <> 0 then begin c := d; raise Exit end ) l1 l2; !c with | Exit -> !c | Invalid_argument _ -> List.length l1 - List.length l2 end) type t = V.t P.t let add p v mp = let prof_p = try P.find p mp with Not_found -> V.empty in if V.mem v prof_p then mp else P.add p (V.add v prof_p) mp let iter = P.iter let empty = P.empty let is_empty = P.is_empty end let assert_has_depth_one (e, _) = match X.term_extract e with | Some t, true -> assert ((T.view t).T.depth = 1); | _ -> () module SMT2LikeModelOutput = struct let x_print fmt (rep , ppr) = fprintf fmt "%s" ppr let print_args fmt l = match l with | [] -> assert false | [t,e] -> fprintf fmt "%a" x_print e; | (t,e) :: l -> fprintf fmt "%a" x_print e; List.iter (fun (t, e) -> fprintf fmt " %a" x_print e) l let print_symb ty fmt f = match f, ty with | Sy.Op Sy.Record, Ty.Trecord {Ty.name} -> fprintf fmt "%a__%s" Sy.print f (Hstring.view name) | _ -> Sy.print fmt f let output_constants_model cprofs = (*printf "; constants:@.";*) Profile.iter (fun (f, xs_ty, ty) st -> match Profile.V.elements st with | [[], rep] -> (*printf " (%a %a) ; %a@." (print_symb ty) f x_print rep Ty.print ty*) printf " (%a %a)@." (print_symb ty) f x_print rep | _ -> assert false )cprofs let output_functions_model fprofs = if not (Profile.is_empty fprofs) then printf "@."; (*printf "@.; functions:@.";*) Profile.iter (fun (f, xs_ty, ty) st -> (*printf " ; fun %a : %a -> %a@." (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) Profile.V.iter (fun (xs, rep) -> printf " ((%a %a) %a)@." (print_symb ty) f print_args xs x_print rep; List.iter (fun (_,x) -> assert_has_depth_one x) xs; )st; printf "@." ) fprofs let output_arrays_model arrays = (*printf "; arrays:@.";*) Profile.iter (fun (f, xs_ty, ty) st -> match xs_ty with [tyi] -> (*printf " ; array %a : %a -> %a@." (print_symb ty) f Ty.print tyi Ty.print ty;*) Profile.V.iter (fun (xs, rep) -> printf " ((%a %a) %a)@." (print_symb ty) f print_args xs x_print rep; List.iter (fun (_,x) -> assert_has_depth_one x) xs; )st; printf "@." | _ -> assert false ) arrays end (* of module SMT2LikeModelOutput *) let is_a_good_model_value (x, _) = match X.leaves x with [] -> true | [y] -> X.equal x y | _ -> false let model_repr_of_term t env mrepr = try MapT.find t mrepr, mrepr with Not_found -> let mk = try MapT.find t env.make with Not_found -> assert false in let rep,_ = try MapX.find mk env.repr with Not_found -> assert false in let cls = try SetT.elements (MapX.find rep env.classes) with Not_found -> assert false in let cls = try List.rev_map (fun s -> s, MapT.find s env.make) cls with Not_found -> assert false in let e = X.choose_adequate_model t rep cls in e, MapT.add t e mrepr let output_concrete_model ({make; repr} as env) = let i = interpretation () in let abs_i = abs i in if abs_i = 1 || abs_i = 2 || abs_i = 3 then let functions, constants, arrays, _ = MapT.fold (fun t mk ((fprofs, cprofs, carrays, mrepr) as acc) -> let {T.f; xs; ty} = T.view t in if X.is_solvable_theory_symbol f || T.is_fresh t || T.is_fresh_skolem t || T.equal t T.vrai || T.equal t T.faux then acc else let xs, tys, mrepr = List.fold_left (fun (xs, tys, mrepr) x -> let rep_x, mrepr = model_repr_of_term x env mrepr in assert (is_a_good_model_value rep_x); (x, rep_x)::xs, (T.type_info x)::tys, mrepr ) ([],[], mrepr) (List.rev xs) in let rep, mrepr = model_repr_of_term t env mrepr in assert (is_a_good_model_value rep); match f, xs, ty with | Sy.Op Sy.Set, _, _ -> acc | Sy.Op Sy.Get, [(_,(a,_));((_,(i,_)) as e)], _ -> begin match X.term_extract a with | Some ta, true -> let {T.f=f_ta;xs=xs_ta; ty=ty_ta} = T.view ta in assert (xs_ta == []); fprofs, cprofs, Profile.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, mrepr | _ -> assert false end | _ -> if tys == [] then fprofs, Profile.add (f, tys, ty) (xs, rep) cprofs, carrays, mrepr else Profile.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, mrepr ) make (Profile.empty, Profile.empty, Profile.empty, MapT.empty) in if i > 0 then begin printf "(\n"; SMT2LikeModelOutput.output_constants_model constants; SMT2LikeModelOutput.output_functions_model functions; SMT2LikeModelOutput.output_arrays_model arrays; printf ")@."; end end alt-ergo-1.30/src/instances/0000755000175000001440000000000013014515065014271 5ustar rtusersalt-ergo-1.30/src/instances/instances.ml0000644000175000001440000003174113014515065016620 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig module T = Term module F = Formula module MF = F.Map module SF = F.Set module Ex = Explanation module MT = T.Map module type S = sig type t type tbox type instances = (F.gformula * Ex.t) list val empty : t val add_terms : t -> T.Set.t -> F.gformula -> t val add_lemma : t -> F.gformula -> Ex.t -> t * instances val add_predicate : t -> F.gformula -> t val m_lemmas : t -> tbox -> (F.t -> F.t -> bool) -> int -> instances * instances (* goal_directed, others *) val m_predicates : t -> tbox -> (F.t -> F.t -> bool) -> int -> instances * instances (* goal_directed, others *) (* returns used axioms/predicates * unused axioms/predicates *) val retrieve_used_context : t -> Ex.t -> Formula.t list * Formula.t list val register_max_term_depth : t -> int -> t end module Make(X : Theory.S) : S with type tbox = X.t = struct module EM = Matching.Make( struct include X let add_term env t = X.add_term env t ~add_in_cs:false end) type tbox = X.t type instances = (F.gformula * Ex.t) list type t = { lemmas : (int * Ex.t) MF.t; predicates : (int * Ex.t) MF.t; matching : EM.t; } let empty = { lemmas = MF.empty ; matching = EM.empty; predicates = MF.empty; } module Debug = struct let new_facts_of_axiom ax insts_ok = if debug_matching () >= 1 && insts_ok != MF.empty then let name = match F.view ax with F.Lemma {F.name=s} -> s | _ -> "!(no-name)" in fprintf fmt "[Instances.split_and_filter_insts] "; fprintf fmt "%3d different new instances generated for %s@." (MF.cardinal insts_ok) name let new_mround ilvl kind = if debug_matching () >= 1 then fprintf fmt "@.# [matching] new %s matching round: ilevel = %d...@." kind ilvl end let add_terms env s gf = let infos = { Matching.term_age = gf.F.age ; term_from_goal = gf.F.gf ; term_from_formula = gf.F.lem ; term_from_terms = gf.F.from_terms } in { env with matching = T.Set.fold (EM.add_term infos) s env.matching } let add_predicate env gf = let {F.f=f;age=age} = gf in if EM.unused_context f then env else { env with predicates = MF.add f (age,Ex.empty) env.predicates; (* this is not done in SAT*) matching = EM.max_term_depth env.matching (F.max_term_depth f) } let register_max_term_depth env mx = {env with matching = EM.max_term_depth env.matching mx} let record_this_instance accepted lorig = match F.view lorig with | F.Lemma {F.name;loc} -> Profiling.new_instance_of name loc accepted | _ -> assert false let profile_produced_terms env lorig nf s trs = let st0 = List.fold_left (fun st t -> T.subterms st (T.apply_subst s t)) T.Set.empty trs in let name, loc, f = match F.view lorig with | F.Lemma {F.name;main;loc} -> name, loc, main | _ -> assert false in let st1 = F.ground_terms_rec nf in let diff = Term.Set.diff st1 st0 in let info = EM.terms_info env.matching in let _new = Term.Set.filter (fun t -> not (MT.mem t info)) diff in Profiling.register_produced_terms name loc st0 st1 diff _new let inst_is_seen_during_this_round orig f insts = try let mp_orig_ok, mp_orig_ko = MF.find orig insts in MF.mem f mp_orig_ok || SF.mem f mp_orig_ko with Not_found -> false let add_accepted_to_acc orig f item insts = let mp_orig_ok, mp_orig_ko = try MF.find orig insts with Not_found -> MF.empty, SF.empty in assert (not (MF.mem f mp_orig_ok)); assert (not (SF.mem f mp_orig_ko)); MF.add orig (MF.add f item mp_orig_ok, mp_orig_ko) insts let add_rejected_to_acc orig f insts = let mp_orig_ok, mp_orig_ko = try MF.find orig insts with Not_found -> MF.empty, SF.empty in assert (not (MF.mem f mp_orig_ok)); assert (not (SF.mem f mp_orig_ko)); MF.add orig (mp_orig_ok, SF.add f mp_orig_ko) insts let new_facts env tbox selector substs = List.fold_left (fun acc ({Matching.trigger_formula=f; trigger_age=age; trigger_dep=dep; trigger_orig=orig; trigger = tr}, subst_list) -> let cpt = ref 0 in let kept = ref 0 in List.fold_left (fun acc {Matching.sbs = sbs; sty = sty; gen = g; goal = b; s_term_orig = torig; s_lem_orig = lorig} -> incr cpt; let s = sbs, sty in match tr.F.guard with | Some a when X.query (Literal.LT.apply_subst s a) tbox==No -> acc | _ -> let nf = F.apply_subst s f in if inst_is_seen_during_this_round orig nf acc then acc else let accepted = selector nf orig in if not accepted then add_rejected_to_acc orig nf acc else let p = { F.f = nf; trigger_depth = tr.F.depth; nb_reductions = 0; age = 1+(max g age); mf = true; gf = b; lem = Some lorig; from_terms = torig } in let dep = if not (Options.proof() || Options.profiling()) then dep else (* Dep lorig used to track conflicted instances in profiling mode *) Ex.union dep (Ex.singleton (Ex.Dep lorig)) in incr kept; add_accepted_to_acc orig nf (p, dep, s, tr.F.content) acc ) acc subst_list ) MF.empty substs let split_and_filter_insts env insts = MF.fold (fun orig (mp_orig_ok, mp_orig_ko) acc -> Debug.new_facts_of_axiom orig mp_orig_ok; let acc = MF.fold (fun f (p, dep, _, _) (gd, ngd) -> if p.F.gf then (p, dep) :: gd, ngd else gd, (p, dep) :: ngd )mp_orig_ok acc in if Options.profiling() then begin (* update profiler data *) SF.iter (fun _ -> record_this_instance false orig) mp_orig_ko; MF.iter (fun f (_, _, name, tr_ctt) -> profile_produced_terms env orig f name tr_ctt; record_this_instance true orig ) mp_orig_ok; end; acc )insts ([], []) let sort_facts = let rec size f = match F.view f with | F.Unit(f1,f2) -> max (size f1) (size f2) | _ -> F.size f in fun lf -> List.fast_sort (fun (p1,_) (p2,_) -> let c = size p1.F.f - size p2.F.f in if c <> 0 then c else F.compare p2.F.f p1.F.f ) lf let new_facts env tbox selector substs = if Options.timers() then try Options.exec_timer_start Timers.M_Match Timers.F_new_facts; let res = new_facts env tbox selector substs in Options.exec_timer_pause Timers.M_Match Timers.F_new_facts; res with e -> Options.exec_timer_pause Timers.M_Match Timers.F_new_facts; raise e else new_facts env tbox selector substs let mround env axs tbox selector ilvl kind = Debug.new_mround ilvl kind; Options.tool_req 2 "TR-Sat-Mround"; let env = {env with matching = EM.add_triggers env.matching axs} in let substs = EM.query env.matching tbox in let insts = new_facts env tbox selector substs in let gd, ngd = split_and_filter_insts env insts in sort_facts gd, sort_facts ngd let m_lemmas env tbox selector ilvl = mround env env.lemmas tbox selector ilvl "axioms" let m_predicates env tbox selector ilvl = mround env env.predicates tbox selector ilvl "predicates" module MI = Map.Make (struct type t = int let compare = compare end) let retrieve_used_context env dep = let deps = Ex.formulas_of dep in let used, unlems, unpreds = SF.fold (fun f ((used, lems, preds) as acc) -> if MF.mem f lems then f :: used, MF.remove f lems, preds else if MF.mem f preds then f :: used, lems, MF.remove f preds else match F.view f with | F.Lemma _ -> (* An axiom that does not appear in lems because of inconsist. *) f :: used, lems, preds | _ -> acc ) deps ([], env.lemmas, env.predicates) in let unused = MF.fold (fun f _ acc -> f::acc) unlems [] in let unused = MF.fold (fun f _ acc -> f::acc) unpreds unused in used, unused let add_lemma env gf dep = let {F.f=orig;age=age;gf=b} = gf in if (*not (Ex.is_empty dep) ||*) EM.unused_context orig then env, [] else let age, dep = try let age' , dep' = MF.find orig env.lemmas in min age age' , Ex.union dep dep' with Not_found -> age, dep in let env = { env with lemmas = MF.add orig (age,dep) env.lemmas } in match F.view orig with | F.Lemma {F.simple_inst = Some sbs; main} -> let nf = F.apply_subst sbs main in let p = { F.f = nf; trigger_depth = max_int; nb_reductions = 0; age = age+1; mf = true; gf = b; lem = Some orig; from_terms = [] } in let dep = if not (Options.proof() || Options.profiling()) then dep else (* Dep lorig used to track conflicted instances in profiling mode *) Ex.union dep (Ex.singleton (Ex.Dep orig)) in let insts = add_accepted_to_acc orig nf (p, dep, sbs, []) MF.empty in let gd, ngd = split_and_filter_insts env insts in env, List.rev_append gd ngd | _ -> env, [] (*** add wrappers to profile exported functions ***) let add_terms env s gf = if Options.timers() then try Options.exec_timer_start Timers.M_Match Timers.F_add_terms; let res = add_terms env s gf in Options.exec_timer_pause Timers.M_Match Timers.F_add_terms; res with e -> Options.exec_timer_pause Timers.M_Match Timers.F_add_terms; raise e else add_terms env s gf let add_lemma env gf dep = if Options.timers() then try Options.exec_timer_start Timers.M_Match Timers.F_add_lemma; let res = add_lemma env gf dep in Options.exec_timer_pause Timers.M_Match Timers.F_add_lemma; res with e -> Options.exec_timer_pause Timers.M_Match Timers.F_add_lemma; raise e else add_lemma env gf dep let add_predicate env gf = if Options.timers() then try Options.exec_timer_start Timers.M_Match Timers.F_add_predicate; let res = add_predicate env gf in Options.exec_timer_pause Timers.M_Match Timers.F_add_predicate; res with e -> Options.exec_timer_pause Timers.M_Match Timers.F_add_predicate; raise e else add_predicate env gf let m_lemmas env tbox selector = if Options.timers() then try Options.exec_timer_start Timers.M_Match Timers.F_m_lemmas; let res = m_lemmas env tbox selector in Options.exec_timer_pause Timers.M_Match Timers.F_m_lemmas; res with e -> Options.exec_timer_pause Timers.M_Match Timers.F_m_lemmas; raise e else m_lemmas env tbox selector let m_predicates env tbox selector = if Options.timers() then try Options.exec_timer_start Timers.M_Match Timers.F_m_predicates; let res = m_predicates env tbox selector in Options.exec_timer_pause Timers.M_Match Timers.F_m_predicates; res with e -> Options.exec_timer_pause Timers.M_Match Timers.F_m_predicates; raise e else m_predicates env tbox selector end alt-ergo-1.30/src/instances/matching.ml0000644000175000001440000004154713014515065016430 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Format open Options open Sig module T = Term module F = Formula module MF = F.Map module Ex = Explanation module MT = T.Map module SubstT = Term.Subst type gsubst = { sbs : T.t SubstT.t; sty : Ty.subst; gen : int ; (* l'age d'une substitution est l'age du plus vieux terme qu'elle contient *) goal : bool; (* vrai si la substitution contient un terme ayant un lien avec le but de la PO *) s_term_orig : T.t list; s_lem_orig : F.t; } type trigger_info = { trigger : F.trigger; trigger_age : int ; (* age d'un trigger *) trigger_orig : F.t ; (* lemme d'origine *) trigger_formula : F.t ; (* formule associee au trigger *) trigger_dep : Ex.t ; } type term_info = { term_age : int ; (* age du terme *) term_from_goal : bool ; (* vrai si le terme provient du but de la PO *) term_from_formula : F.t option; (* lemme d'origine du terme *) term_from_terms : T.t list; } type info = { age : int ; (* age du terme *) lem_orig : F.t list ; (* lemme d'ou provient eventuellement le terme *) t_orig : T.t list; but : bool (* le terme a-t-il un lien avec le but final de la PO *) } module type S = sig type t type theory val empty : t val add_term : term_info -> Term.t -> t -> t val max_term_depth : t -> int -> t val add_triggers : t -> (int * Explanation.t) Formula.Map.t -> t val terms_info : t -> info Term.Map.t val query : t -> theory -> (trigger_info * gsubst list) list val unused_context : Formula.t -> bool end module type Arg = sig type t val term_repr : t -> Term.t -> Term.t val add_term : t -> Term.t -> t val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val class_of : t -> Term.t -> Term.t list end module Make (X : Arg) : S with type theory = X.t = struct type theory = X.t type t = { fils : T.t list MT.t SubstT.t ; info : info MT.t ; max_t_depth : int; pats : trigger_info list } exception Echec let empty = { fils = SubstT.empty ; info = MT.empty ; pats = [ ]; max_t_depth = 0; } let age_limite = Options.age_bound (* l'age limite des termes, au dela ils ne sont pas consideres par le matching *) (*BISECT-IGNORE-BEGIN*) module Debug = struct let add_term t = if debug_matching() >= 3 then fprintf fmt "[matching] add_term: %a@." T.print t let matching tr = if debug_matching() >= 3 then begin fprintf fmt "@.[matching] (multi-)trigger: %a@." T.print_list tr.F.content; fprintf fmt "========================================================@." end let match_pats_modulo pat lsubsts = if debug_matching() >= 3 then begin fprintf fmt "@.match_pat_modulo: %a with accumulated substs@." T.print pat; List.iter (fun {sbs=sbs; sty=sty} -> fprintf fmt ">>> sbs= %a | sty= %a@." (SubstT.print Term.print) sbs Ty.print_subst sty )lsubsts end let match_one_pat {sbs=sbs; sty=sty} pat0 = if debug_matching() >= 3 then fprintf fmt "@.match_pat: %a with subst: sbs= %a | sty= %a @." T.print pat0 (SubstT.print Term.print) sbs Ty.print_subst sty let match_one_pat_against {sbs=sbs; sty=sty} pat0 t = if debug_matching() >= 3 then fprintf fmt "@.match_pat: %a against term %a@.with subst: sbs= %a | sty= %a @." T.print pat0 T.print t (SubstT.print Term.print) sbs Ty.print_subst sty let match_term {sbs=sbs; sty=sty} t pat = if debug_matching() >= 3 then fprintf fmt "[match_term] I match %a against %a with subst: sbs=%a | sty= %a@." T.print pat T.print t (SubstT.print Term.print) sbs Ty.print_subst sty let match_list {sbs=sbs; sty=sty} pats xs = if debug_matching() >= 3 then fprintf fmt "@.[match_list] I match %a against %a with subst: sbs=%a | sty= %a@." T.print_list pats T.print_list xs (SubstT.print Term.print) sbs Ty.print_subst sty let match_class_of t cl = if debug_matching() >= 3 then fprintf fmt "class_of (%a) = { %a }@." T.print t (fun fmt -> List.iter (fprintf fmt "%a , " T.print)) cl let candidate_substitutions pat_info res = if debug_matching() >= 1 then begin fprintf fmt "[Matching.matching]@."; fprintf fmt "%3d candidate substitutions for Axiom %a with trigger %a@." (List.length res) F.print pat_info.trigger_orig T.print_list pat_info.trigger.F.content; if debug_matching() >= 2 then List.iter (fun gsbt -> fprintf fmt " >>> sbs = %a and sbty = %a@." (SubstT.print T.print) gsbt.sbs Ty.print_subst gsbt.sty )res end end (*BISECT-IGNORE-END*) let infos op_gen op_but t g b env = try let i = MT.find t env.info in op_gen i.age g , op_but i.but b with Not_found -> g , b let add_term info t env = Debug.add_term t; let rec add_rec env t = if MT.mem t env.info then env else let {T.f=f; xs=xs} = T.view t in let env = let map_f = try SubstT.find f env.fils with Not_found -> MT.empty in (* - l'age d'un terme est le min entre l'age passe en argument et l'age dans la map - un terme est en lien avec le but de la PO seulement s'il ne peut etre produit autrement (d'ou le &&) - le lemme de provenance est le dernier lemme *) let g, b = infos min (&&) t info.term_age info.term_from_goal env in let from_lems = List.fold_left (fun acc t -> try (MT.find t env.info).lem_orig @ acc with Not_found -> acc) (match info.term_from_formula with None -> [] | Some a -> [a]) info.term_from_terms in { env with fils = SubstT.add f (MT.add t xs map_f) env.fils; info = MT.add t { age=g; lem_orig = from_lems; but=b; t_orig = info.term_from_terms } env.info } in List.fold_left add_rec env xs in if info.term_age > age_limite () then env else add_rec env t let add_trigger p env = { env with pats = p :: env.pats } let all_terms f ty env tbox {sbs=s_t; sty=s_ty; gen=g; goal=b; s_term_orig=s_torig; s_lem_orig = s_lorig} lsbt_acc = SubstT.fold (fun k s l -> MT.fold (fun t _ l -> try let s_ty = Ty.matching s_ty ty (T.view t).T.ty in let ng , but = try let {age=ng;lem_orig=lem'; but=bt} = MT.find t env.info in max ng g , bt || b with Not_found -> g , b in (* with triggers that are variables, always normalize substs *) let t = X.term_repr (X.add_term tbox t) t in { sbs = SubstT.add f t s_t; sty = s_ty; gen = ng; goal = but; s_term_orig = t :: s_torig; s_lem_orig = s_lorig; }::l with Ty.TypeClash _ -> l ) s l ) env.fils lsbt_acc module T2 = struct type t = T.t * T.t let compare (a, b) (x, y) = let c = T.compare a x in if c <> 0 then c else T.compare b y end module MT2 = Map.Make(T2) let wrap_are_equal_generic tbox t s add_terms cache_are_eq_gen = try MT2.find (t, s) !cache_are_eq_gen with Not_found -> let res = X.are_equal tbox t s ~add_terms:add_terms in cache_are_eq_gen := MT2.add (t, s) res (MT2.add (s, t) res !cache_are_eq_gen); res (* These references are reset before and after each call to query. If some intermediate functions are exported in the future, the code should be adapted. *) let cache_are_equal_light = ref MT2.empty let cache_are_equal_full = ref MT2.empty let are_equal_light tbox t s = wrap_are_equal_generic tbox t s false cache_are_equal_light let are_equal_full tbox t s = wrap_are_equal_generic tbox t s true cache_are_equal_full let add_msymb tbox f t ({sbs=s_t} as sg) max_t_depth = if SubstT.mem f s_t then let s = SubstT.find f s_t in if are_equal_full tbox t s == Sig.No then raise Echec; sg else let t = if (T.view t).T.depth > max_t_depth || normalize_instances () then X.term_repr (X.add_term tbox t) t else t in {sg with sbs=SubstT.add f t s_t} let (-@) l1 l2 = match l1, l2 with | [], _ -> l2 | _ , [] -> l1 | _ -> List.fold_left (fun acc e -> e :: acc) l2 (List.rev l1) let xs_modulo_records t { Ty.lbs = lbs } = List.rev (List.rev_map (fun (hs, ty) -> T.make (Symbols.Op (Symbols.Access hs)) [t] ty) lbs) module SLT = (* sets of lists of terms *) Set.Make(struct type t = T.t list let compare l1 l2 = try List.iter2 (fun t1 t2 -> let c = T.compare t1 t2 in if c <> 0 then raise (Exception.Compared c) ) l1 l2; 0 with Invalid_argument _ -> List.length l1 - List.length l2 | Exception.Compared n -> n end) let filter_classes cl tbox = if no_Ematching () then cl else let mtl = List.fold_left (fun acc xs -> let xs = List.rev (List.rev_map (fun t -> X.term_repr tbox t) xs) in SLT.add xs acc ) SLT.empty cl in SLT.elements mtl let rec match_term env tbox ({sty=s_ty;gen=g;goal=b} as sg) pat t = Options.exec_thread_yield (); Debug.match_term sg t pat; let {T.f=f_pat;xs=pats;ty=ty_pat} = T.view pat in match f_pat with | Symbols.Var _ -> let sb = (try let s_ty = Ty.matching s_ty ty_pat (T.view t).T.ty in let g',b' = infos max (||) t g b env in add_msymb tbox f_pat t { sg with sty=s_ty; gen=g'; goal=b' } env.max_t_depth with Ty.TypeClash _ -> raise Echec) in [sb] | _ -> try let s_ty = Ty.matching s_ty ty_pat (T.view t).T.ty in let gsb = { sg with sty = s_ty } in if T.is_ground pat && are_equal_light tbox pat t != Sig.No then [gsb] else let cl = if no_Ematching () then [t] else X.class_of tbox t in Debug.match_class_of t cl; let cl = List.fold_left (fun l t -> let {T.f=f; xs=xs; ty=ty} = T.view t in if Symbols.compare f_pat f = 0 then xs::l else begin match f_pat, ty with | Symbols.Op (Symbols.Record), Ty.Trecord record -> (xs_modulo_records t record) :: l | _ -> l end )[] cl in let cl = filter_classes cl tbox in List.fold_left (fun acc xs -> try (match_list env tbox gsb pats xs) -@ acc with Echec -> acc ) [] cl with Ty.TypeClash _ -> raise Echec and match_list env tbox sg pats xs = Debug.match_list sg pats xs; try List.fold_left2 (fun sb_l pat arg -> List.fold_left (fun acc sg -> let aux = match_term env tbox sg pat arg in (*match aux with [] -> raise Echec | _ -> BUG !! *) List.rev_append aux acc ) [] sb_l ) [sg] pats xs with Invalid_argument _ -> raise Echec let match_one_pat env tbox pat0 lsbt_acc sg = Debug.match_one_pat sg pat0; let pat = T.apply_subst (sg.sbs, sg.sty) pat0 in let {T.f=f; xs=pats; ty=ty} = T.view pat in match f with | Symbols.Var _ -> all_terms f ty env tbox sg lsbt_acc | _ -> let {sty=sty; gen=g; goal=b} = sg in let f_aux t xs lsbt = Debug.match_one_pat_against sg pat0 t; try let s_ty = Ty.matching sty ty (T.view t).T.ty in let gen, but = infos max (||) t g b env in let sg = { sg with sty = s_ty; gen = gen; goal = but; s_term_orig = t::sg.s_term_orig } in let aux = match_list env tbox sg pats xs in List.rev_append aux lsbt with Echec | Ty.TypeClash _ -> lsbt in try MT.fold f_aux (SubstT.find f env.fils) lsbt_acc with Not_found -> lsbt_acc let match_pats_modulo env tbox lsubsts pat = Debug.match_pats_modulo pat lsubsts; List.fold_left (match_one_pat env tbox pat) [] lsubsts let matching env tbox pat_info = let pats = pat_info.trigger in let pats_list = List.stable_sort (fun s t -> (T.view t).T.depth - (T.view s).T.depth) pats.F.content in Debug.matching pats; let egs = { sbs = SubstT.empty; sty = Ty.esubst; gen = 0; goal = false; s_term_orig = []; s_lem_orig = pat_info.trigger_orig; } in let res = List.fold_left (match_pats_modulo env tbox) [egs] pats_list in Debug.candidate_substitutions pat_info res; pat_info, res let reset_cache_refs () = cache_are_equal_light := MT2.empty; cache_are_equal_full := MT2.empty let query env tbox = reset_cache_refs (); try let res = List.rev_map (matching env tbox) env.pats in reset_cache_refs (); res with e -> reset_cache_refs (); raise e let query env tbox = if Options.timers() then try Options.exec_timer_start Timers.M_Match Timers.F_query; let res = query env tbox in Options.exec_timer_pause Timers.M_Match Timers.F_query; res with e -> Options.exec_timer_pause Timers.M_Match Timers.F_query; raise e else query env tbox let max_term_depth env mx = {env with max_t_depth = max env.max_t_depth mx} let add_triggers env formulas = MF.fold (fun lem (age, dep) env -> match F.view lem with | F.Lemma {F.triggers = tgs; main = f} -> List.fold_left (fun env tr -> let info = { trigger = tr; trigger_age = age ; trigger_orig = lem ; trigger_formula = f ; trigger_dep = dep} in add_trigger info env ) env tgs | _ -> assert false ) formulas env let terms_info env = env.info module SST = Set.Make(String) let init_with_replay_used acc f = if Sys.command (sprintf "[ -e %s ]" f) <> 0 then begin fprintf fmt "File %s not found! Option -replay-used will be ignored@." f; acc end else let cin = open_in f in let acc = ref (match acc with None -> SST.empty | Some ss -> ss) in begin try while true do acc := SST.add (input_line cin) !acc done; with End_of_file -> close_in cin end; Some !acc let used = if Options.replay_used_context () then init_with_replay_used None (Options.get_used_context_file ()) else if Options.replay_all_used_context () then let dir = Filename.dirname (Options.get_used_context_file ()) in Array.fold_left (fun acc f -> let f = sprintf "%s/%s" dir f in if (Filename.check_suffix f ".used") then begin init_with_replay_used acc f end else acc ) None (Sys.readdir dir) else None let parent s = if String.length s = 0 then s else match s.[0] with | '#' -> (match Str.split (Str.regexp "#") s with | [a;b] -> a | _ -> assert false) | _ -> s let unused_context f = match used, F.view f with | None , _ -> false | Some s_used, F.Lemma {F.name=s} -> not (String.length s = 0 || SST.mem (parent s) s_used) | _ -> assert false end alt-ergo-1.30/src/instances/matching.mli0000644000175000001440000000636113014515065016574 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) type gsubst = { sbs : Term.t Term.Subst.t; sty : Ty.subst; gen : int ; (* l'age d'une substitution est l'age du plus vieux terme qu'elle contient *) goal : bool; (* vrai si la substitution contient un terme ayant un lien avec le but de la PO *) s_term_orig : Term.t list; s_lem_orig : Formula.t; } type trigger_info = { trigger : Formula.trigger; trigger_age : int ; (* age d'un trigger *) trigger_orig : Formula.t ; (* lemme d'origine *) trigger_formula : Formula.t ; (* formule associee au trigger *) trigger_dep : Explanation.t ; } type term_info = { term_age : int ; (* age du terme *) term_from_goal : bool ; (* vrai si le terme provient du but de la PO *) term_from_formula : Formula.t option; (* lemme d'origine du terme *) term_from_terms : Term.t list; } type info = { age : int ; (* age du terme *) lem_orig : Formula.t list ; (* lemme d'ou provient eventuellement le terme *) t_orig : Term.t list; but : bool (* le terme a-t-il un lien avec le but final de la PO *) } module type S = sig type t type theory val empty : t val add_term : term_info -> Term.t -> t -> t val max_term_depth : t -> int -> t val add_triggers : t -> (int * Explanation.t) Formula.Map.t -> t val terms_info : t -> info Term.Map.t val query : t -> theory -> (trigger_info * gsubst list) list val unused_context : Formula.t -> bool end module type Arg = sig type t val term_repr : t -> Term.t -> Term.t val add_term : t -> Term.t -> t val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val class_of : t -> Term.t -> Term.t list end module Make (X : Arg) : S with type theory = X.t alt-ergo-1.30/src/instances/instances.mli0000644000175000001440000000465113014515065016771 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) module type S = sig type t type tbox type instances = (Formula.gformula * Explanation.t) list val empty : t val add_terms : t -> Term.Set.t -> Formula.gformula -> t val add_lemma : t -> Formula.gformula -> Explanation.t -> t * instances val add_predicate : t -> Formula.gformula -> t val m_lemmas : t -> tbox -> (Formula.t -> Formula.t -> bool) -> int -> instances * instances (* goal_directed, others *) val m_predicates : t -> tbox -> (Formula.t -> Formula.t -> bool) -> int -> instances * instances (* goal_directed, others *) (* returns used axioms/predicates * unused axioms/predicates *) val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list val register_max_term_depth : t -> int -> t end module Make (X : Theory.S) : S with type tbox = X.t alt-ergo-1.30/src/preprocess/0000755000175000001440000000000013014515065014467 5ustar rtusersalt-ergo-1.30/src/preprocess/existantial.ml0000644000175000001440000001201113014515065017341 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Typed open Options let eq_var x t = match t.c.tt_desc with | TTvar y -> Symbols.equal x y | _ -> false let no_occur_check x t = let rec aux t = match t.c.tt_desc with | TTvar y -> if Symbols.equal x y then raise Exit | TTlet (y, s, t) -> aux s; if not (Symbols.equal x y) then aux t | TTrecord l -> List.iter (fun (_,t) -> aux t) l | TTnamed (_, t) -> aux t | TTdot (t, _) -> aux t | TTconcat (s, t) -> aux s; aux t | TTextract (r, s, t) -> aux r; aux s; aux t | TTset (r, s, t) -> aux r; aux s; aux t | TTget (s, t) -> aux s; aux t | TTapp (_, l) -> List.iter aux l | TTprefix (_, t) -> aux t | TTinfix (s, _, t) -> aux s; aux t | TTconst _ -> () in try aux t; true with Exit -> false let rec find_eq x eqs f = match f.c with | TFatom ({c=TAeq [t1;t2]}) -> if eq_var x t1 && no_occur_check x t2 then (x,t2)::eqs else if eq_var x t2 && no_occur_check x t1 then (x,t1)::eqs else eqs | TFop (OPand,l) -> List.fold_left (find_eq x) eqs l | _ -> eqs (* XXX: TODO *) let find_equalities lv f = List.fold_left (fun eqs (x,_) -> let l = find_eq x [] f in if l == [] then raise Not_found; l::eqs ) [] lv let rec apply_subst_term env t = let tt = match t.c.tt_desc with | TTvar x as tt -> (try (List.assoc x env).c.tt_desc with Not_found -> tt) | TTapp(s,l) -> TTapp(s,List.map (apply_subst_term env) l) | TTget(t1,t2) -> TTget(apply_subst_term env t1, apply_subst_term env t2) | TTset(t1,t2,t3) -> TTset(apply_subst_term env t1, apply_subst_term env t2, apply_subst_term env t3) | TTinfix(t1,s,t2) -> TTinfix(apply_subst_term env t1,s,apply_subst_term env t2) | TTextract (t1,t2,t3) -> TTextract (apply_subst_term env t1, apply_subst_term env t2, apply_subst_term env t3) | TTconcat (t1,t2) -> TTconcat(apply_subst_term env t1, apply_subst_term env t2) | TTdot (t, l) -> TTdot (apply_subst_term env t, l) | TTrecord r -> TTrecord (List.map (fun (l,t) -> l, apply_subst_term env t) r) | TTlet (s, t1, t2) -> TTlet (s, apply_subst_term env t1, apply_subst_term env t2) | TTnamed (n, t) -> TTnamed (n, apply_subst_term env t) | TTprefix (s, t) -> TTprefix (s, apply_subst_term env t) | (TTconst _) as tt -> tt in { t with c = { t.c with tt_desc = tt }} let rec apply_subst_formula env f = let c = match f.c with | TFatom e -> let a = match e.c with | TAeq l -> TAeq (List.map (apply_subst_term env) l) | TAneq l -> TAneq (List.map (apply_subst_term env) l) | TAdistinct l -> TAdistinct (List.map (apply_subst_term env) l) | TAle l -> TAle (List.map (apply_subst_term env) l) | TAlt l -> TAlt (List.map (apply_subst_term env) l) | TAbuilt(s,l) -> TAbuilt(s,List.map (apply_subst_term env) l) | TApred t -> TApred (apply_subst_term env t) | TAfalse | TAtrue -> e.c in TFatom {e with c = a} | TFop (op, lf) -> TFop (op, List.map (apply_subst_formula env) lf) | TFforall _ | TFexists _ -> f.c (* XXX: TODO *) | _ -> f.c in { f with c = c } let make_instance f = let lt = find_equalities f.qf_bvars f.qf_form in apply_subst_formula (List.map List.hd lt) f.qf_form let make f = if Options.rm_eq_existential () then try (*TFop(OPor,[TFexists f;*) (make_instance f).c (*])*) with Not_found -> TFexists f else TFexists f alt-ergo-1.30/src/preprocess/existantial.mli0000644000175000001440000000321113014515065017514 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Typed val make : int quant_form -> int tform alt-ergo-1.30/src/preprocess/why_typing.mli0000644000175000001440000000367313014515065017404 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Parsed open Typed type env val empty_env : env val file : bool -> env -> file -> ((int tdecl, int) annoted * env) list * env val split_goals : ((int tdecl, int) annoted * env) list -> ((int tdecl, int) annoted * env) list list val term : env -> (Symbols.t * Ty.t) list -> Parsed.lexpr -> (int tterm, int) annoted val new_id : unit -> int alt-ergo-1.30/src/preprocess/cnf.ml0000644000175000001440000002353613014515065015600 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format open Typed open Commands module T = Term module F = Formula module A = Literal module Sy = Symbols let ale = Hstring.make "<=" let alt = Hstring.make "<" let varset_of_list = List.fold_left (fun acc (s,ty) -> Term.Set.add (Term.make s [] (Ty.shorten ty)) acc) Term.Set.empty let rec make_term {c = { tt_ty = ty; tt_desc = tt }} = let ty = Ty.shorten ty in match tt with | TTconst Ttrue -> T.vrai | TTconst Tfalse -> T.faux | TTconst Tvoid -> T.void | TTconst (Tint i) -> T.int i | TTconst (Treal n) -> T.real (Num.string_of_num n) | TTconst (Tbitv bt) -> T.bitv bt ty | TTvar s -> T.make s [] ty | TTapp (s, l) -> T.make s (List.map make_term l) ty | TTinfix (t1, s, t2) -> T.make s [make_term t1;make_term t2] ty | TTprefix ((Sy.Op Sy.Minus) as s, n) -> let t1 = if ty == Ty.Tint then T.int "0" else T.real "0" in T.make s [t1; make_term n] ty | TTprefix _ -> assert false | TTget (t1, t2) -> T.make (Sy.Op Sy.Get) [make_term t1; make_term t2] ty | TTset (t1, t2, t3) -> let t1 = make_term t1 in let t2 = make_term t2 in let t3 = make_term t3 in T.make (Sy.Op Sy.Set) [t1; t2; t3] ty | TTextract (t1, t2, t3) -> let t1 = make_term t1 in let t2 = make_term t2 in let t3 = make_term t3 in T.make (Sy.Op Sy.Extract) [t1; t2; t3] ty | TTconcat (t1, t2) -> T.make (Sy.Op Sy.Concat) [make_term t1; make_term t2] ty | TTdot (t, s) -> T.make (Sy.Op (Sy.Access s)) [make_term t] ty | TTrecord lbs -> let lbs = List.map (fun (_, t) -> make_term t) lbs in T.make (Sy.Op Sy.Record) lbs ty | TTlet (s, t1, t2) -> let t1 = make_term t1 in let subst = Sy.Map.add s t1 Sy.Map.empty, Ty.esubst in let t2 = make_term t2 in T.apply_subst subst t2 | TTnamed(lbl, t) -> let t = make_term t in T.add_label lbl t; t let make_trigger (e, from_user) = let content, guard = match e with | [{c={ tt_desc = TTapp(s, t1::t2::l)}}] when Sy.equal s Sy.fake_eq -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_eq (make_term t1) (make_term t2) in trs, Some lit | [{c={ tt_desc = TTapp(s, t1::t2::l) } }] when Sy.equal s Sy.fake_neq -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_distinct false [make_term t1; make_term t2] in trs, Some lit | [{c={ tt_desc = TTapp(s, t1::t2::l) } }] when Sy.equal s Sy.fake_le -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_builtin true ale [make_term t1; make_term t2] in trs, Some lit | [{c={ tt_desc = TTapp(s, t1::t2::l) } }] when Sy.equal s Sy.fake_lt -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_builtin true alt [make_term t1; make_term t2] in trs, Some lit | lt -> List.map make_term lt, None in let depth = List.fold_left (fun z t -> max z (T.view t).T.depth) 0 content in { F.content ; guard ; depth; from_user} let make_form name_base f loc = let name_tag = ref 0 in let rec make_form toplevel acc c id = match c with | TFatom a -> let a , lit = match a.c with | TAtrue -> A.LT.vrai , A.LT.vrai::acc | TAfalse -> A.LT.faux , A.LT.faux::acc | TAeq [t1;t2] -> let lit = A.LT.mk_eq (make_term t1) (make_term t2) in lit , lit::acc | TApred t -> let lit = A.LT.mk_pred (make_term t) false in lit , lit::acc | TAneq lt | TAdistinct lt -> let lt = List.map make_term lt in let lit = A.LT.mk_distinct false lt in lit , lit::acc | TAle [t1;t2] -> let lit = A.LT.mk_builtin true ale [make_term t1;make_term t2] in lit , lit::acc | TAlt [t1;t2] -> begin match t1.c.tt_ty with | Ty.Tint -> let one = {c = {tt_ty = Ty.Tint; tt_desc = TTconst(Tint "1")}; annot = t1.annot} in let tt2 = T.make (Sy.Op Sy.Minus) [make_term t2; make_term one] Ty.Tint in let lit = A.LT.mk_builtin true ale [make_term t1; tt2] in lit , lit::acc | _ -> let lit = A.LT.mk_builtin true alt [make_term t1; make_term t2] in lit, lit::acc end | TAbuilt(n,lt) -> let lit = A.LT.mk_builtin true n (List.map make_term lt) in lit , lit::acc | _ -> assert false in F.mk_lit a id, lit | TFop(((OPand | OPor) as op),[f1;f2]) -> let ff1 , lit1 = make_form false acc f1.c f1.annot in let ff2 , lit2 = make_form false lit1 f2.c f2.annot in let mkop = match op with | OPand -> F.mk_and ff1 ff2 false id | _ -> F.mk_or ff1 ff2 false id in mkop , lit2 | TFop(OPimp,[f1;f2]) -> let ff1 , _ = make_form false acc f1.c f1.annot in let ff2 , lit = make_form false acc f2.c f2.annot in F.mk_imp ff1 ff2 id, lit | TFop(OPnot,[f]) -> let ff , lit = make_form false acc f.c f.annot in F.mk_not ff , lit | TFop(OPif t,[f2;f3]) -> let tt = make_term t in let ff2 , lit2 = make_form false acc f2.c f2.annot in let ff3 , lit3 = make_form false lit2 f3.c f3.annot in F.mk_if tt ff2 ff3 id, lit3 | TFop(OPiff,[f1;f2]) -> let ff1 , lit1 = make_form false acc f1.c f1.annot in let ff2 , lit2 = make_form false lit1 f2.c f2.annot in F.mk_iff ff1 ff2 id, lit2 | (TFforall qf | TFexists qf) as f -> let name = if !name_tag = 0 then name_base else sprintf "#%s#sub-%d" name_base !name_tag in incr name_tag; let qvars = varset_of_list qf.qf_bvars in let binders = F.mk_binders qvars in (*let upvars = varset_of_list qf.qf_upvars in*) let trs = List.map make_trigger qf.qf_triggers in let ff , lit = make_form false acc qf.qf_form.c qf.qf_form.annot in begin match f with | TFforall _ -> F.mk_forall name loc binders trs ff id None, lit | TFexists _ -> if toplevel && not (Ty.Set.is_empty (F.type_variables ff)) then (* If there is type variables in a toplevel exists: 1 - we add a forall quantification without term variables (ie. only with type variables) 2 - we keep the triggers of 'exists' to try to instantiate type variables with these triggers as guards *) let nm = sprintf "#%s#sub-%d" name_base 0 in let gg = F.mk_exists nm loc binders trs ff id None in F.mk_forall name loc Symbols.Map.empty trs gg id None, lit else F.mk_exists name loc binders trs ff id None, lit | _ -> assert false end | TFlet(up,lvar,lterm,lf) -> let ff, lit = make_form false acc lf.c lf.annot in F.mk_let (varset_of_list up) lvar (make_term lterm) ff id, lit | TFnamed(lbl, f) -> let ff, lit = make_form false acc f.c f.annot in F.add_label lbl ff; ff, lit | _ -> assert false in make_form true [] f.c f.annot let push_assume queue f name loc match_flag = let ff , _ = make_form name f loc in Queue.push {st_decl=Assume(ff, match_flag) ; st_loc=loc} queue let push_preddef queue f name loc match_flag = let ff , _ = make_form name f loc in Queue.push {st_decl=PredDef (ff, name) ; st_loc=loc} queue let push_query queue n f loc sort = let ff, lits = make_form "" f loc in Queue.push {st_decl=Query(n, ff, lits, sort) ; st_loc=loc} queue let make_rule ({rwt_left = t1; rwt_right = t2} as r) = { r with rwt_left = make_term t1; rwt_right = make_term t2 } let make l = let queue = Queue.create () in List.iter (fun (d,b) -> match d.c with | TAxiom(loc, name, f) -> push_assume queue f name loc b | TRewriting(loc, name, lr) -> Queue.push {st_decl=RwtDef(List.map make_rule lr); st_loc=loc} queue | TGoal(loc, sort, n, f) -> push_query queue n f loc sort (*| TPredicate_def(loc, n, [], f) -> push_preddef queue f n loc b*) | TPredicate_def(loc, n, _, f) -> push_preddef queue f n loc b | TFunction_def(loc, n, _, _, f) -> push_assume queue f n loc b | TTypeDecl _ | TLogic _ -> ()) l; queue alt-ergo-1.30/src/preprocess/triggers.mli0000644000175000001440000000352713014515065017027 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Typed (* make k b f computes the triggers for a formula f if k is true existing triggers are checked if b is true then variables are authorized in multi-triggers *) val make : bool -> bool -> (int tform, int) annoted -> (int tform, int) annoted alt-ergo-1.30/src/preprocess/cnf.mli0000644000175000001440000000326613014515065015747 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) val make : ((int Typed.tdecl, int) Typed.annoted * bool) list -> Commands.sat_tdecl Queue.t alt-ergo-1.30/src/preprocess/why_typing.ml0000644000175000001440000014353413014515065017234 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format open Parsed open Typed open Errors module S = Set.Make(String) module Sy = Symbols.Set module MString = Map.Make(struct type t = string let compare = Pervasives.compare end) module Types = struct (* environment for user-defined types *) type t = { to_ty : Ty.t MString.t; from_labels : string MString.t; } let to_tyvars = ref MString.empty let empty = { to_ty = MString.empty; from_labels = MString.empty } let fresh_vars env vars loc = List.map (fun x -> if MString.mem x !to_tyvars then error (TypeDuplicateVar x) loc; let nv = Ty.Tvar (Ty.fresh_var ()) in to_tyvars := MString.add x nv !to_tyvars; nv ) vars let check_number_args loc lty ty = match ty with | Ty.Text (lty', s) | Ty.Trecord {Ty.args=lty'; name=s} -> if List.length lty <> List.length lty' then error (WrongNumberofArgs (Hstring.view s)) loc; lty' | Ty.Tsum (s, _) -> if List.length lty <> 0 then error (WrongNumberofArgs (Hstring.view s)) loc; [] | _ -> assert false let equal_pp_vars lpp lvars = try List.for_all2 (fun pp x -> match pp with | PPTvarid (y, _) -> Pervasives.(=) x y | _ -> false ) lpp lvars with Invalid_argument _ -> false let rec ty_of_pp loc env rectype = function | PPTint -> Ty.Tint | PPTbool -> Ty.Tbool | PPTunit -> Ty.Tunit | PPTreal -> Ty.Treal | PPTbitv n -> Ty.Tbitv n | PPTvarid (s, _) -> begin try MString.find s !to_tyvars with Not_found -> let nty = Ty.Tvar (Ty.fresh_var ()) in to_tyvars := MString.add s nty !to_tyvars; nty end | PPTexternal (l, s, loc) when Pervasives.(=) s "farray" -> let t1,t2 = match l with | [t2] -> PPTint,t2 | [t1;t2] -> t1,t2 | _ -> error (WrongArity(s,2)) loc in let ty1 = ty_of_pp loc env rectype t1 in let ty2 = ty_of_pp loc env rectype t2 in Ty.Tfarray (ty1, ty2) | PPTexternal (l, s, loc) -> begin match rectype with | Some (id, vars, ty) when Pervasives.(=) s id && equal_pp_vars l vars -> ty | _ -> try let lty = List.map (ty_of_pp loc env rectype) l in let ty = MString.find s env.to_ty in let vars = check_number_args loc lty ty in Ty.instantiate vars lty ty with Not_found -> error (UnknownType s) loc end let add env vars id body loc = if MString.mem id env.to_ty then error (ClashType id) loc; let ty_vars = fresh_vars env vars loc in match body with | Abstract -> { env with to_ty = MString.add id (Ty.text ty_vars id) env.to_ty } | Enum lc -> { env with to_ty = MString.add id (Ty.tsum id lc) env.to_ty } | Record lbs -> let lbs = List.map (fun (x, pp) -> x, ty_of_pp loc env None pp) lbs in { to_ty = MString.add id (Ty.trecord ty_vars id lbs) env.to_ty; from_labels = List.fold_left (fun fl (l,_) -> MString.add l id fl) env.from_labels lbs } module SH = Set.Make(Hstring) let check_labels lbs ty loc = let rec check_duplicates s = function | [] -> () | (lb, _) :: l -> if SH.mem lb s then error (DuplicateLabel lb) loc; check_duplicates (SH.add lb s) l in check_duplicates SH.empty lbs; match ty with | Ty.Trecord {Ty.lbs=l} -> if List.length lbs <> List.length l then error WrongNumberOfLabels loc; List.iter (fun (lb, _) -> try ignore (Hstring.list_assoc lb l) with Not_found -> error (WrongLabel(lb, ty)) loc) lbs; ty | _ -> assert false let from_labels env lbs loc = match lbs with | [] -> assert false | (l, _) :: _ -> try let l = Hstring.view l in let ty = MString.find (MString.find l env.from_labels) env.to_ty in check_labels lbs ty loc with Not_found -> error (NoRecordType l) loc let rec monomorphized = function | PPTvarid (x, _) when not (MString.mem x !to_tyvars) -> to_tyvars := MString.add x (Ty.fresh_empty_text ()) !to_tyvars; | PPTexternal (args, _, _) -> List.iter monomorphized args | pp_ty -> () let init_labels fl id loc = function | Record lbs -> List.fold_left (fun fl (s, _) -> if MString.mem s fl then error (ClashLabel (s, (MString.find s fl))) loc; MString.add s id fl) fl lbs | _ -> fl end module Env = struct type profile = { args : Ty.t list; result : Ty.t } type t = { var_map : (Symbols.t * Ty.t) MString.t ; (* variables' map*) types : Types.t ; logics : (Symbols.t * profile) MString.t (* logic symbols' map *) } let empty = { var_map = MString.empty; types = Types.empty; logics = MString.empty } let add env lv fvar ty = let vmap = List.fold_left (fun vmap x -> MString.add x (fvar x, ty) vmap) env.var_map lv in { env with var_map = vmap } let add_var env lv pp_ty loc = let ty = Types.ty_of_pp loc env.types None pp_ty in add env lv Symbols.var ty let add_names env lv pp_ty loc = Types.monomorphized pp_ty; let ty = Types.ty_of_pp loc env.types None pp_ty in add env lv Symbols.name ty let add_names_lbl env lv pp_ty loc = Types.monomorphized pp_ty; let ty = Types.ty_of_pp loc env.types None pp_ty in let rlv = List.fold_left (fun acc (x, lbl) -> let lbl = Hstring.make lbl in if not (Hstring.equal lbl Hstring.empty) then Symbols.add_label lbl (Symbols.name x); x::acc ) [] lv in let lv = List.rev rlv in add env lv Symbols.name ty let add_logics env ac names pp_profile loc = let profile = match pp_profile with | PPredicate args -> { args = List.map (Types.ty_of_pp loc env.types None) args; result = Ty.Tbool } (*| PFunction ([], PPTvarid (_, loc)) -> error CannotGeneralize loc*) | PFunction(args, res) -> let args = List.map (Types.ty_of_pp loc env.types None) args in let res = Types.ty_of_pp loc env.types None res in { args = args; result = res } in let logics = List.fold_left (fun logics (n, lbl) -> let sy = Symbols.name n ~kind:ac in if MString.mem n logics then error (SymbAlreadyDefined n) loc; let lbl = Hstring.make lbl in if not (Hstring.equal lbl Hstring.empty) then Symbols.add_label lbl sy; MString.add n (sy, profile) logics) env.logics names in { env with logics = logics } let find {var_map=m} n = MString.find n m let mem n {var_map=m} = MString.mem n m let list_of {var_map=m} = MString.fold (fun _ c acc -> c::acc) m [] let add_type_decl env vars id body loc = { env with types = Types.add env.types vars id body loc } (* returns a type with fresh variables *) let fresh_type env n loc = try let s, { args = args; result = r} = MString.find n env.logics in let args, subst = Ty.fresh_list args Ty.esubst in let res, _ = Ty.fresh r subst in s, { args = args; result = res } with Not_found -> error (SymbUndefined n) loc end let new_id = let r = ref 0 in fun () -> r := !r+1; !r let rec freevars_term acc t = match t.c.tt_desc with | TTvar x -> Sy.add x acc | TTapp (_,lt) -> List.fold_left freevars_term acc lt | TTinfix (t1,_,t2) | TTget(t1, t2) -> List.fold_left freevars_term acc [t1; t2] | TTset (t1, t2, t3) -> List.fold_left freevars_term acc [t1; t2; t3] | TTdot (t1, _) -> freevars_term acc t1 | TTrecord lbs -> List.fold_left (fun acc (_, t) -> freevars_term acc t) acc lbs | TTconst _ -> acc | TTprefix (_, t) -> freevars_term acc t | TTconcat (t1, t2) -> freevars_term (freevars_term acc t1) t2 | TTnamed (_, t) -> freevars_term acc t | TTextract (t1, t2, t3) -> freevars_term (freevars_term (freevars_term acc t1) t2) t3 | TTlet (sy, t1, t2) -> let acc_t1 = freevars_term acc t1 in let acc_t2 = freevars_term acc_t1 t2 in if Sy.mem sy acc_t1 then acc_t2 (* the symbol sy is already a free var in acc or t1 -> keep it *) else Sy.remove sy acc_t2 (* the symbol sy is not a free var *) let freevars_atom a = match a.c with | TAeq lt | TAneq lt | TAle lt | TAlt lt | TAbuilt(_,lt) | TAdistinct lt -> List.fold_left freevars_term Sy.empty lt | TApred t -> freevars_term Sy.empty t | _ -> Sy.empty let rec freevars_form f = match f with | TFatom a -> freevars_atom a | TFop (_,lf) -> List.fold_left Sy.union Sy.empty (List.map (fun f -> freevars_form f.c) lf) | TFforall qf | TFexists qf -> let s = freevars_form qf.qf_form.c in List.fold_left (fun acc (s,_) -> Sy.remove s acc) s qf.qf_bvars | TFlet(up,v,t,f) -> freevars_term (Sy.remove v (freevars_form f.c)) t | TFnamed(_, f) -> freevars_form f.c let symbol_of = function PPadd -> Symbols.Op Symbols.Plus | PPsub -> Symbols.Op Symbols.Minus | PPmul -> Symbols.Op Symbols.Mult | PPdiv -> Symbols.Op Symbols.Div | PPmod -> Symbols.Op Symbols.Modulo | _ -> assert false let append_type msg ty = fprintf str_formatter "%s %a" msg Ty.print ty; flush_str_formatter () let rec type_term env f = let e,t = type_term_desc env f.pp_loc f.pp_desc in {c = { tt_desc = e ; tt_ty = t }; annot = new_id ()} and type_term_desc env loc = function | PPconst ConstTrue -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tbool); TTconst Ttrue, Ty.Tbool | PPconst ConstFalse -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tbool); TTconst Tfalse, Ty.Tbool | PPconst ConstVoid -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tunit); TTconst Tvoid, Ty.Tunit | PPconst (ConstInt n) -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tint); TTconst(Tint n), Ty.Tint | PPconst (ConstReal n) -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Treal); TTconst(Treal n), Ty.Treal | PPconst (ConstBitv n) -> Options.tool_req 1 (append_type "TR-Typing-Const type" (Ty.Tbitv (String.length n))); TTconst(Tbitv n), Ty.Tbitv (String.length n) | PPvar p -> begin try let s,t = Env.find env p in Options.tool_req 1 (append_type "TR-Typing-Var$_\\Gamma$ type" t); TTvar s , t with Not_found -> match Env.fresh_type env p loc with | s, { Env.args = []; result = ty} -> Options.tool_req 1 (append_type "TR-Typing-Var$_\\Delta$ type" ty); TTvar s , ty | _ -> error (ShouldBeApply p) loc end | PPapp(p,args) -> begin let te_args = List.map (type_term env) args in let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in let s, {Env.args = lt; result = t} = Env.fresh_type env p loc in try List.iter2 Ty.unify lt lt_args; Options.tool_req 1 (append_type "TR-Typing-App type" t); TTapp(s,te_args), t with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc | Invalid_argument _ -> error (WrongNumberofArgs p) loc end | PPinfix(t1,(PPadd | PPsub | PPmul | PPdiv as op),t2) -> begin let s = symbol_of op in let te1 = type_term env t1 in let te2 = type_term env t2 in let ty1 = Ty.shorten te1.c.tt_ty in let ty2 = Ty.shorten te2.c.tt_ty in match ty1, ty2 with | Ty.Tint, Ty.Tint -> Options.tool_req 1 (append_type "TR-Typing-OpBin type" ty1); TTinfix(te1,s,te2) , ty1 | Ty.Treal, Ty.Treal -> Options.tool_req 1 (append_type "TR-Typing-OpBin type" ty2); TTinfix(te1,s,te2), ty2 | Ty.Tint, _ -> error (ShouldHaveType(ty2,Ty.Tint)) t2.pp_loc | Ty.Treal, _ -> error (ShouldHaveType(ty2,Ty.Treal)) t2.pp_loc | _ -> error (ShouldHaveTypeIntorReal ty1) t1.pp_loc end | PPinfix(t1, PPmod, t2) -> begin let s = symbol_of PPmod in let te1 = type_term env t1 in let te2 = type_term env t2 in let ty1 = Ty.shorten te1.c.tt_ty in let ty2 = Ty.shorten te2.c.tt_ty in match ty1, ty2 with | Ty.Tint, Ty.Tint -> Options.tool_req 1 (append_type "TR-Typing-OpMod type" ty1); TTinfix(te1,s,te2) , ty1 | _ -> error (ShouldHaveTypeInt ty1) t1.pp_loc end | PPprefix(PPneg, {pp_desc=PPconst (ConstInt n)}) -> Options.tool_req 1 (append_type "TR-Typing-OpUnarith type" Ty.Tint); TTconst(Tint ("-"^n)), Ty.Tint | PPprefix(PPneg, {pp_desc=PPconst (ConstReal n)}) -> Options.tool_req 1 (append_type "TR-Typing-OpUnarith type" Ty.Treal); TTconst(Treal (Num.minus_num n)), Ty.Treal | PPprefix(PPneg, e) -> let te = type_term env e in let ty = Ty.shorten te.c.tt_ty in if ty!=Ty.Tint && ty!=Ty.Treal then error (ShouldHaveTypeIntorReal ty) e.pp_loc; Options.tool_req 1 (append_type "TR-Typing-OpUnarith type" ty); TTprefix(Symbols.Op Symbols.Minus, te), ty | PPconcat(t1, t2) -> begin let te1 = type_term env t1 in let te2 = type_term env t2 in let ty1 = Ty.shorten te1.c.tt_ty in let ty2 = Ty.shorten te2.c.tt_ty in match ty1, ty2 with | Ty.Tbitv n , Ty.Tbitv m -> Options.tool_req 1 (append_type "TR-Typing-OpConcat type" (Ty.Tbitv (n+m))); TTconcat(te1, te2), Ty.Tbitv (n+m) | Ty.Tbitv _ , _ -> error (ShouldHaveTypeBitv ty2) t2.pp_loc | _ , Ty.Tbitv _ -> error (ShouldHaveTypeBitv ty1) t1.pp_loc | _ -> error (ShouldHaveTypeBitv ty1) t1.pp_loc end | PPextract(e, ({pp_desc=PPconst(ConstInt i)} as ei), ({pp_desc=PPconst(ConstInt j)} as ej)) -> begin let te = type_term env e in let tye = Ty.shorten te.c.tt_ty in let i = int_of_string i in let j = int_of_string j in match tye with | Ty.Tbitv n -> if i>j then error (BitvExtract(i,j)) loc; if j>=n then error (BitvExtractRange(n,j) ) loc; let tei = type_term env ei in let tej = type_term env ej in Options.tool_req 1 (append_type "TR-Typing-OpExtract type" (Ty.Tbitv (j-i+1))); TTextract(te, tei, tej), Ty.Tbitv (j-i+1) | _ -> error (ShouldHaveType(tye,Ty.Tbitv (j+1))) loc end | PPget (t1, t2) -> begin let te1 = type_term env t1 in let te2 = type_term env t2 in let tyarray = Ty.shorten te1.c.tt_ty in let tykey2 = Ty.shorten te2.c.tt_ty in match tyarray with | Ty.Tfarray (tykey,tyval) -> begin try Ty.unify tykey tykey2; Options.tool_req 1 (append_type "TR-Typing-OpGet type" tyval); TTget(te1, te2), tyval with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc end | _ -> error ShouldHaveTypeArray t1.pp_loc end | PPset (t1, t2, t3) -> begin let te1 = type_term env t1 in let te2 = type_term env t2 in let te3 = type_term env t3 in let ty1 = Ty.shorten te1.c.tt_ty in let tykey2 = Ty.shorten te2.c.tt_ty in let tyval2 = Ty.shorten te3.c.tt_ty in try match ty1 with | Ty.Tfarray (tykey,tyval) -> Ty.unify tykey tykey2;Ty.unify tyval tyval2; Options.tool_req 1 (append_type "TR-Typing-OpSet type" ty1); TTset(te1, te2, te3), ty1 | _ -> error ShouldHaveTypeArray t1.pp_loc with | Ty.TypeClash(t, t') -> error (Unification(t, t')) loc end | PPif(t1,t2,t3) -> begin let te1 = type_term env t1 in let ty1 = Ty.shorten te1.c.tt_ty in if not (Ty.equal ty1 Ty.Tbool) then error (ShouldHaveType(ty1,Ty.Tbool)) t1.pp_loc; let te2 = type_term env t2 in let te3 = type_term env t3 in let ty2 = Ty.shorten te2.c.tt_ty in let ty3 = Ty.shorten te3.c.tt_ty in if not (Ty.equal ty2 ty3) then error (ShouldHaveType(ty3,ty2)) t3.pp_loc; Options.tool_req 1 (append_type "TR-Typing-Ite type" ty2); TTapp(Symbols.name "ite",[te1;te2;te3]) , ty2 end | PPdot(t, a) -> begin let te = type_term env t in let ty = Ty.shorten te.c.tt_ty in match ty with | Ty.Trecord {Ty.name=g; lbs=lbs} -> begin try let a = Hstring.make a in TTdot(te, a), Hstring.list_assoc a lbs with Not_found -> let g = Hstring.view g in error (ShouldHaveLabel(g,a)) t.pp_loc end | _ -> error (ShouldHaveTypeRecord ty) t.pp_loc end | PPrecord lbs -> begin let lbs = List.map (fun (lb, t) -> Hstring.make lb, type_term env t) lbs in let lbs = List.sort (fun (l1, _) (l2, _) -> Hstring.compare l1 l2) lbs in let ty = Types.from_labels env.Env.types lbs loc in let ty, _ = Ty.fresh (Ty.shorten ty) Ty.esubst in match ty with | Ty.Trecord {Ty.lbs=ty_lbs} -> begin try let lbs = List.map2 (fun (s, te) (lb,ty_lb)-> Ty.unify te.c.tt_ty ty_lb; lb, te) lbs ty_lbs in TTrecord(lbs), ty with Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc end | _ -> error ShouldBeARecord loc end | PPwith(e, lbs) -> begin let te = type_term env e in let lbs = List.map (fun (lb, t) -> Hstring.make lb, (type_term env t, t.pp_loc)) lbs in let ty = Ty.shorten te.c.tt_ty in match ty with | Ty.Trecord {Ty.lbs=ty_lbs} -> let nlbs = List.map (fun (lb, ty_lb) -> try let v, _ = Hstring.list_assoc lb lbs in Ty.unify ty_lb v.c.tt_ty; lb, v with | Not_found -> lb, {c = { tt_desc = TTdot(te, lb); tt_ty = ty_lb}; annot = te.annot } | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc ) ty_lbs in List.iter (fun (lb, _) -> try ignore (Hstring.list_assoc lb ty_lbs) with Not_found -> error (NoLabelInType(lb, ty)) loc) lbs; TTrecord(nlbs), ty | _ -> error ShouldBeARecord loc end | PPlet(x, t1, t2) -> let te1 = type_term env t1 in let ty1 = Ty.shorten te1.c.tt_ty in let env = Env.add env [x] Symbols.var ty1 in let te2 = type_term env t2 in let ty2 = Ty.shorten te2.c.tt_ty in let s, _ = Env.find env x in Options.tool_req 1 (append_type "TR-Typing-Let type" ty2); TTlet(s, te1, te2), ty2 (* | PPnamed(lbl, t) -> *) (* let te = type_term env t in *) (* te.c.tt_desc, te.c.tt_ty *) | PPnamed (lbl, t) -> let te = type_term env t in let ty = Ty.shorten te.c.tt_ty in let lbl = Hstring.make lbl in TTnamed (lbl, te), ty | PPcast (t,ty) -> let ty = Types.ty_of_pp loc env.Env.types None ty in let te = type_term env t in begin try Ty.unify te.c.tt_ty ty; te.c.tt_desc, Ty.shorten te.c.tt_ty with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc end | _ -> error SyntaxError loc let rec join_forall f = match f.pp_desc with | PPforall(vs, ty, trs1, f) -> let tyvars,trs2,f = join_forall f in (vs,ty)::tyvars , trs1@trs2 , f | PPforall_named (vs, ty, trs1, f) -> let vs = List.map fst vs in join_forall {f with pp_desc = PPforall (vs, ty, trs1, f)} | PPnamed(lbl, f) -> join_forall f | _ -> [] , [] , f let rec join_exists f = match f.pp_desc with | PPexists (vars, ty, trs1, f) -> let tyvars,trs2,f = join_exists f in (vars, ty)::tyvars , trs1@trs2, f | PPexists_named (vs, ty, trs1, f) -> let vs = List.map fst vs in join_exists {f with pp_desc = PPexists (vs, ty, trs1, f)} | PPnamed (_, f) -> join_exists f | _ -> [] , [] , f let rec type_form env f = let rec type_pp_desc pp_desc = match pp_desc with | PPconst ConstTrue -> Options.tool_req 1 "TR-Typing-True$_F$"; TFatom {c=TAtrue; annot=new_id ()}, Sy.empty | PPconst ConstFalse -> Options.tool_req 1 "TR-Typing-False$_F$"; TFatom {c=TAfalse; annot=new_id ()}, Sy.empty | PPvar p -> Options.tool_req 1 "TR-Typing-Var$_F$"; let r = begin match Env.fresh_type env p f.pp_loc with | s, { Env.args = []; result = Ty.Tbool} -> let t2 = {c = {tt_desc=TTconst Ttrue;tt_ty=Ty.Tbool}; annot = new_id ()} in let t1 = {c = {tt_desc=TTvar s; tt_ty=Ty.Tbool}; annot = new_id ()} in TFatom {c = TAeq [t1;t2]; annot=new_id ()} | _ -> error (NotAPropVar p) f.pp_loc end in r, freevars_form r | PPapp(p,args ) -> Options.tool_req 1 "TR-Typing-App$_F$"; let r = begin let te_args = List.map (type_term env) args in let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in match Env.fresh_type env p f.pp_loc with | s , { Env.args = lt; result = Ty.Tbool} -> begin try List.iter2 Ty.unify lt lt_args; if Pervasives.(=) p "<=" || Pervasives.(=) p "<" then TFatom { c = TAbuilt(Hstring.make p,te_args); annot=new_id ()} else let t1 = { c = {tt_desc=TTapp(s,te_args); tt_ty=Ty.Tbool}; annot=new_id (); } in TFatom { c = TApred t1; annot=new_id () } with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc | Invalid_argument _ -> error (WrongNumberofArgs p) f.pp_loc end | _ -> error (NotAPredicate p) f.pp_loc end in r, freevars_form r | PPdistinct (args) -> Options.tool_req 1 "TR-Typing-Distinct$_F$"; let r = begin let te_args = List.map (type_term env) args in let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in try let t = match lt_args with | t::_ -> t | [] -> error (WrongNumberofArgs "distinct") f.pp_loc in List.iter (Ty.unify t) lt_args; TFatom { c = TAdistinct te_args; annot=new_id () } with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc end in r, freevars_form r | PPinfix ({pp_desc = PPinfix (_, (PPlt|PPle|PPgt|PPge|PPeq|PPneq), a)} as p, (PPlt | PPle | PPgt | PPge | PPeq | PPneq as r), b) -> Options.tool_req 1 "TR-Typing-OpComp$_F$"; let r = let q = { pp_desc = PPinfix (a, r, b); pp_loc = f.pp_loc } in let f1,_ = type_form env p in let f2,_ = type_form env q in TFop(OPand, [f1;f2]) in r, freevars_form r | PPinfix(t1, (PPeq | PPneq as op), t2) -> Options.tool_req 1 "TR-Typing-OpBin$_F$"; let r = let tt1 = type_term env t1 in let tt2 = type_term env t2 in try Ty.unify tt1.c.tt_ty tt2.c.tt_ty; match op with | PPeq -> TFatom {c = TAeq [tt1; tt2]; annot = new_id()} | PPneq -> TFatom {c = TAneq [tt1; tt2]; annot = new_id()} | _ -> assert false with Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc in r, freevars_form r | PPinfix(t1, (PPlt | PPgt | PPge | PPle as op), t2) -> Options.tool_req 1 "TR-Typing-OpComp$_F$"; let r = let tt1 = type_term env t1 in let tt2 = type_term env t2 in try Ty.unify tt1.c.tt_ty tt2.c.tt_ty; let ty = Ty.shorten tt1.c.tt_ty in match ty with | Ty.Tint | Ty.Treal -> let top = match op with | PPlt -> TAlt [tt1; tt2] | PPgt -> TAlt [tt2; tt1] | PPle -> TAle [tt1; tt2] | PPge -> TAle [tt2; tt1] | PPeq -> TAeq [tt1; tt2] | PPneq -> TAneq [tt1; tt2] | _ -> assert false in TFatom {c = top; annot=new_id ()} | _ -> error (ShouldHaveTypeIntorReal ty) t1.pp_loc with Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc in r, freevars_form r | PPinfix(f1,op ,f2) -> Options.tool_req 1 "TR-Typing-OpConnectors$_F$"; begin let f1,fv1 = type_form env f1 in let f2,fv2 = type_form env f2 in ((match op with | PPand -> TFop(OPand,[f1;f2]) | PPor -> TFop(OPor,[f1;f2]) | PPimplies -> TFop(OPimp,[f1;f2]) | PPiff -> TFop(OPiff,[f1;f2]) | _ -> assert false), Sy.union fv1 fv2) end | PPprefix(PPnot,f) -> Options.tool_req 1 "TR-Typing-OpNot$_F$"; let f, fv = type_form env f in TFop(OPnot,[f]),fv | PPif(f1,f2,f3) -> Options.tool_req 1 "TR-Typing-Ite$_F$"; let f1 = type_term env f1 in let f2,fv2 = type_form env f2 in let f3,fv3 = type_form env f3 in TFop(OPif f1,[f2;f3]), Sy.union fv2 fv3 | PPnamed(lbl,f) -> let f, fv = type_form env f in let lbl = Hstring.make lbl in TFnamed(lbl, f), fv | PPforall _ | PPexists _ -> let ty_vars, ty, triggers, f' = match pp_desc with | PPforall(vars,ty,triggers,f') -> let ty_vars, triggers', f' = join_forall f' in (vars, ty)::ty_vars,ty ,triggers@triggers', f' | PPexists(vars,ty,triggers,f') -> let ty_vars, triggers', f' = join_exists f' in (vars, ty)::ty_vars, ty, triggers@triggers', f' | _ -> assert false in let env' = List.fold_left (fun env (lv, pp_ty) -> Env.add_var env lv pp_ty f.pp_loc) env ty_vars in let f', fv = type_form env' f' in let ty_triggers = List.map (fun (tr, b) -> List.map (type_term env') tr, b) triggers in let upbvars = Env.list_of env in let bvars = List.fold_left (fun acc (l,_) -> let tys = List.map (Env.find env') l in let tys = List.filter (fun (s,_) -> Sy.mem s fv) tys in tys @ acc) [] ty_vars in let qf_form = { qf_upvars = upbvars ; qf_bvars = bvars ; qf_triggers = ty_triggers ; qf_form = f'} in (match pp_desc with | PPforall _ -> Options.tool_req 1 "TR-Typing-Forall$_F$"; TFforall qf_form | PPexists _ -> Options.tool_req 1 "TR-Typing-Exists$_F$"; Existantial.make qf_form | _ -> assert false), (List.fold_left (fun acc (l,_) -> Sy.remove l acc) fv bvars) | PPlet (var,t,f) -> Options.tool_req 1 "TR-Typing-Let$_F$"; let {c= { tt_ty = ttype }} as tt = type_term env t in let svar = Symbols.var var in let up = Env.list_of env in let env = {env with Env.var_map = MString.add var (svar, ttype) env.Env.var_map} in let f,fv = type_form env f in TFlet (up ,svar , tt, f), freevars_term (Sy.remove svar fv) tt (* Remove labels : *) | PPforall_named (lx, tys, trs, f) -> let lx = List.map fst lx in type_pp_desc (PPforall (lx, tys, trs, f)) | PPexists_named (lx, tys, trs, f) -> let lx = List.map fst lx in type_pp_desc (PPexists (lx, tys, trs, f)) | PPcheck _ | PPcut _ -> assert false | _ -> let te1 = type_term env f in let ty = te1.c.tt_ty in match ty with | Ty.Tbool -> let te2 = {c = {tt_desc=TTconst Ttrue;tt_ty=Ty.Tbool}; annot = new_id ()} in let r = TFatom {c = TAeq [te1;te2]; annot=new_id ()} in r, freevars_form r | _ -> error ShouldHaveTypeProp f.pp_loc in let form, vars = type_pp_desc f.pp_desc in {c = form; annot = new_id ()}, vars let make_rules loc f = match f.c with | TFforall {qf_bvars = vars; qf_form = {c = TFatom {c = TAeq [t1; t2]}}} -> {rwt_vars = vars; rwt_left = t1; rwt_right = t2} | TFatom {c = TAeq [t1; t2]} -> {rwt_vars = []; rwt_left = t1; rwt_right = t2} | _ -> error SyntaxError loc let fresh_var = let cpt = ref 0 in fun x -> incr cpt; ("_"^x^(string_of_int !cpt)) let rec no_alpha_renaming_b ((up, m) as s) f = match f.pp_desc with | PPvar x -> (try let y = MString.find x m in assert (String.compare x y <> 0); raise Exit with Not_found -> ()) | PPapp(k, l) -> List.iter (no_alpha_renaming_b s) l | PPdistinct l -> List.iter (no_alpha_renaming_b s) l | PPconst _ -> () | PPinfix(f1, op, f2) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2 | PPprefix(op, f1) -> no_alpha_renaming_b s f1 | PPget(f1,f2) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2 | PPset(f1, f2, f3) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2; no_alpha_renaming_b s f3 | PPextract(f1, f2, f3) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2; no_alpha_renaming_b s f3 | PPconcat(f1, f2) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2 | PPif(f1, f2, f3) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2; no_alpha_renaming_b s f3 | PPnamed(n, f1) -> no_alpha_renaming_b s f1 | PPdot(f1, a) -> no_alpha_renaming_b s f1 | PPrecord l -> List.iter (fun (_,e) -> no_alpha_renaming_b s e) l | PPwith(e, l) -> List.iter (fun (_,e) -> no_alpha_renaming_b s e) l; no_alpha_renaming_b s e | PPlet(x, f1, f2) -> no_alpha_renaming_b s f1; let s, x = if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx else (S.add x up, m), x in no_alpha_renaming_b s f2 | PPcheck f' -> no_alpha_renaming_b s f' | PPcut f' -> no_alpha_renaming_b s f' | PPcast (f',ty) -> no_alpha_renaming_b s f' | PPforall(xs, ty, trs, f1) -> let xs1, xs2 = List.partition (fun x -> S.mem x up) xs in let nv = List.map fresh_var xs1 in let m = List.fold_left2 (fun m x nx -> MString.add x nx m) m xs1 nv in let xs = nv@xs2 in let up = List.fold_left (fun up x -> S.add x up) up xs in let s = (up, m) in no_alpha_renaming_b s f1; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs | PPforall_named (xs, ty, trs, f1) -> let xs1, xs2 = List.partition (fun (x, _) -> S.mem x up) xs in let nv = List.map (fun (x, lbl) -> fresh_var x, lbl) xs1 in let m = List.fold_left2 (fun m (x,_) (nx, _) -> MString.add x nx m) m xs1 nv in let xs = nv@xs2 in let up = List.fold_left (fun up (x, _) -> S.add x up) up xs in let s = (up, m) in no_alpha_renaming_b s f1; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs | PPexists(lx, ty, trs, f1) -> let s, lx = List.fold_left (fun (s, lx) x -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx :: lx else (S.add x up, m), x :: lx) (s, []) lx in no_alpha_renaming_b s f1; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs | PPexists_named (lx, ty, trs, f1) -> let s, lx = List.fold_left (fun (s, lx) (x, lbl) -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), (nx, lbl) :: lx else (S.add x up, m), (x, lbl) :: lx) (s, []) lx in no_alpha_renaming_b s f1; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs let rec alpha_renaming_b ((up, m) as s) f = match f.pp_desc with | PPvar x -> (try let y = MString.find x m in assert (String.compare x y <> 0); {f with pp_desc = PPvar y} with Not_found -> f) | PPapp(k, l) -> let l2 = List.rev (List.rev_map (alpha_renaming_b s) l) in if List.for_all2 (fun a b -> a == b) l l2 then f else {f with pp_desc = PPapp(k, l2)} | PPdistinct l -> let l2 = List.rev (List.rev_map (alpha_renaming_b s) l) in if List.for_all2 (fun a b -> a == b) l l2 then f else {f with pp_desc = PPdistinct l2} | PPconst _ -> f | PPinfix(f1, op, f2) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in if f1 == ff1 && f2 == ff2 then f else {f with pp_desc = PPinfix(ff1, op, ff2)} | PPprefix(op, f1) -> let ff1 = alpha_renaming_b s f1 in if f1 == ff1 then f else {f with pp_desc = PPprefix(op, ff1)} | PPget(f1,f2) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in if f1 == ff1 && f2 == ff2 then f else {f with pp_desc = PPget(ff1, ff2)} | PPset(f1, f2, f3) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in let ff3 = alpha_renaming_b s f3 in if f1 == ff1 && f2 == ff2 && f3 == ff3 then f else {f with pp_desc = PPset(ff1, ff2, ff3)} | PPextract(f1, f2, f3) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in let ff3 = alpha_renaming_b s f3 in if f1 == ff1 && f2 == ff2 && f3 == ff3 then f else {f with pp_desc = PPextract(ff1, ff2, ff3)} | PPconcat(f1, f2) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in if ff1 == f1 && ff2 == f2 then f else {f with pp_desc = PPconcat(ff1, ff2)} | PPif(f1, f2, f3) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in let ff3 = alpha_renaming_b s f3 in if f1 == ff1 && f2 == ff2 && f3 == ff3 then f else {f with pp_desc = PPif(ff1, ff2, ff3)} | PPnamed(n, f1) -> let ff1 = alpha_renaming_b s f1 in if f1 == ff1 then f else {f with pp_desc = PPnamed(n, ff1)} | PPdot(f1, a) -> let ff1 = alpha_renaming_b s f1 in if f1 == ff1 then f else {f with pp_desc = PPdot(ff1, a)} | PPrecord l -> let l2 = List.rev (List.rev_map (fun (a,e) -> a, alpha_renaming_b s e) l) in if List.for_all2 (fun a b -> a == b) l l2 then f else {f with pp_desc = PPrecord l2} | PPwith(e, l) -> let l2 = List.rev (List.rev_map (fun (a,e) -> a, alpha_renaming_b s e) l) in let ee = alpha_renaming_b s e in if List.for_all2 (fun a b -> a == b) l l2 && e == ee then f else {f with pp_desc = PPwith(ee, l2)} | PPlet(x, f1, f2) -> let ff1 = alpha_renaming_b s f1 in let s, x = if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx else (S.add x up, m), x in let ff2 = alpha_renaming_b s f2 in if f1 == ff1 && f2 == ff2 then f else {f with pp_desc = PPlet(x, ff1, ff2)} | PPcheck f' -> let ff = alpha_renaming_b s f' in if f' == ff then f else {f with pp_desc = PPcheck ff} | PPcut f' -> let ff = alpha_renaming_b s f' in if f' == ff then f else {f with pp_desc = PPcut ff} | PPcast (f',ty) -> let ff = alpha_renaming_b s f' in if f' == ff then f else {f with pp_desc = PPcast (ff,ty)} | PPforall(xs, ty, trs, f1) -> let xs1, xs2 = List.partition (fun x -> S.mem x up) xs in let nv = List.map fresh_var xs1 in let m = List.fold_left2 (fun m x nx -> MString.add x nx m) m xs1 nv in let xs = nv@xs2 in let up = List.fold_left (fun up x -> S.add x up) up xs in let s = (up, m) in let ff1 = alpha_renaming_b s f1 in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 then f else {f with pp_desc = PPforall(xs, ty, trs2, ff1)} | PPforall_named (xs, ty, trs, f1) -> let xs1, xs2 = List.partition (fun (x, _) -> S.mem x up) xs in let nv = List.map (fun (x, lbl) -> fresh_var x, lbl) xs1 in let m = List.fold_left2 (fun m (x,_) (nx, _) -> MString.add x nx m) m xs1 nv in let xs = nv@xs2 in let up = List.fold_left (fun up (x, _) -> S.add x up) up xs in let s = (up, m) in let ff1 = alpha_renaming_b s f1 in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 then f else {f with pp_desc = PPforall_named (xs, ty, trs2, ff1)} | PPexists(lx, ty, trs, f1) -> let s, lx = List.fold_left (fun (s, lx) x -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx :: lx else (S.add x up, m), x :: lx) (s, []) lx in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in let ff1 = alpha_renaming_b s f1 in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 then f else {f with pp_desc = PPexists(lx, ty, trs2, ff1)} | PPexists_named (lx, ty, trs, f1) -> let s, lx = List.fold_left (fun (s, lx) (x, lbl) -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), (nx, lbl) :: lx else (S.add x up, m), (x, lbl) :: lx) (s, []) lx in let ff1 = alpha_renaming_b s f1 in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 then f else {f with pp_desc = PPexists_named (lx, ty, trs2, ff1)} let alpha_renaming_b s f = try no_alpha_renaming_b s f; f with Exit -> alpha_renaming_b s f let alpha_renaming = alpha_renaming_b (S.empty, MString.empty) let alpha_renaming_env env = let up = MString.fold (fun s _ up -> S.add s up) env.Env.logics S.empty in let up = MString.fold (fun s _ up -> S.add s up) env.Env.var_map up in alpha_renaming_b (up, MString.empty) let inv_infix = function | PPand -> PPor | PPor -> PPand | _ -> assert false let rec elim_toplevel_forall env bnot f = (* bnot = true : nombre impaire de not *) match f.pp_desc with | PPforall (lv, pp_ty, _, f) when bnot-> elim_toplevel_forall (Env.add_names env lv pp_ty f.pp_loc) bnot f | PPforall_named (lvb, pp_ty, _, f) when bnot-> elim_toplevel_forall (Env.add_names_lbl env lvb pp_ty f.pp_loc) bnot f | PPinfix (f1, PPand, f2) when not bnot -> let f1 , env = elim_toplevel_forall env false f1 in let f2 , env = elim_toplevel_forall env false (alpha_renaming_env env f2) in { f with pp_desc = PPinfix(f1, PPand , f2)}, env | PPinfix (f1, PPor, f2) when bnot -> let f1 , env = elim_toplevel_forall env true f1 in let f2 , env = elim_toplevel_forall env true (alpha_renaming_env env f2) in { f with pp_desc = PPinfix(f1, PPand , f2)}, env | PPinfix (f1, PPimplies, f2) when bnot -> let f1 , env = elim_toplevel_forall env false f1 in let f2 , env = elim_toplevel_forall env true (alpha_renaming_env env f2) in { f with pp_desc = PPinfix(f1,PPand,f2)}, env | PPprefix (PPnot, f) -> elim_toplevel_forall env (not bnot) f | _ when bnot -> { f with pp_desc = PPprefix (PPnot, f) }, env | _ -> f , env let rec intro_hypothesis env valid_mode f = match f.pp_desc with | PPinfix(f1,PPimplies,f2) when valid_mode -> let ((f1, env) as f1_env) = elim_toplevel_forall env (not valid_mode) f1 in let axioms, goal = intro_hypothesis env valid_mode (alpha_renaming_env env f2) in f1_env::axioms, goal | PPlet(var,{pp_desc=PPcast(t1,ty); pp_loc = ty_loc},f2) -> let env = Env.add_names env [var] ty ty_loc in let var = {pp_desc = PPvar var; pp_loc = f.pp_loc} in let feq = {pp_desc = PPinfix(var,PPeq,t1); pp_loc = f.pp_loc} in let axioms, goal = intro_hypothesis env valid_mode (alpha_renaming_env env f2) in (feq,env)::axioms, goal | PPforall (lv, pp_ty, _, f) when valid_mode -> intro_hypothesis (Env.add_names env lv pp_ty f.pp_loc) valid_mode f | PPexists (lv, pp_ty, _, f) when not valid_mode-> intro_hypothesis (Env.add_names env lv pp_ty f.pp_loc) valid_mode f | PPforall_named (lvb, pp_ty, _, f) when valid_mode -> intro_hypothesis (Env.add_names_lbl env lvb pp_ty f.pp_loc) valid_mode f | PPexists_named (lvb, pp_ty, _, f) when not valid_mode-> intro_hypothesis (Env.add_names_lbl env lvb pp_ty f.pp_loc) valid_mode f | _ -> let f_env = elim_toplevel_forall env valid_mode f in [] , f_env let fresh_hypothesis_name = let cpt = ref 0 in fun sort -> incr cpt; match sort with | Thm -> "@H"^(string_of_int !cpt) | _ -> "@L"^(string_of_int !cpt) let fresh_check_name = let cpt = ref 0 in fun () -> incr cpt; "check_"^(string_of_int !cpt) let fresh_cut_name = let cpt = ref 0 in fun () -> incr cpt; "cut_"^(string_of_int !cpt) let check_duplicate_params l = let rec loop l acc = match l with | [] -> () | (loc,x,_)::rem -> if List.mem x acc then error (ClashParam x) loc else loop rem (x::acc) in loop l [] let rec make_pred loc trs f = function [] -> f | [x,t] -> { pp_desc = PPforall([x],t,trs,f) ; pp_loc = loc } | (x,t)::l -> { pp_desc = PPforall([x],t,[],(make_pred loc trs f l)) ; pp_loc = loc } let rec max_terms acc f = match f.pp_desc with | PPinfix(f1, ( PPand | PPor | PPimplies | PPiff ), f2) | PPconcat(f1, f2) -> let acc = max_terms acc f1 in max_terms acc f2 | PPforall(_, _, _, _) | PPexists(_, _, _, _) | PPforall_named(_, _, _, _) | PPexists_named(_, _, _, _) | PPvar _ | PPlet(_, _, _) | PPinfix(_, _, _) -> raise Exit | PPif(f1, f2, f3) -> let acc = max_terms acc f1 in let acc = max_terms acc f2 in max_terms acc f3 | PPextract(f1, _, _) | PPprefix(_, f1) | PPnamed(_, f1) -> max_terms acc f1 | _ -> f::acc let max_terms f = try max_terms [] f with Exit -> [] let rec mono_term {c = {tt_ty=tt_ty; tt_desc=tt_desc}; annot = id} = let tt_desc = match tt_desc with | TTconst _ | TTvar _ -> tt_desc | TTinfix (t1, sy, t2) -> TTinfix(mono_term t1, sy, mono_term t2) | TTprefix (sy,t) -> TTprefix(sy, mono_term t) | TTapp (sy,tl) -> TTapp (sy, List.map mono_term tl) | TTget (t1,t2) -> TTget (mono_term t1, mono_term t2) | TTset (t1,t2,t3) -> TTset(mono_term t1, mono_term t2, mono_term t3) | TTextract (t1,t2,t3) -> TTextract(mono_term t1, mono_term t2, mono_term t3) | TTconcat (t1,t2)-> TTconcat (mono_term t1, mono_term t2) | TTdot (t1, a) -> TTdot (mono_term t1, a) | TTrecord lbs -> TTrecord (List.map (fun (x, t) -> x, mono_term t) lbs) | TTlet (sy,t1,t2)-> TTlet (sy, mono_term t1, mono_term t2) | TTnamed (lbl, t)-> TTnamed (lbl, mono_term t) in { c = {tt_ty = Ty.monomorphize tt_ty; tt_desc=tt_desc}; annot = id} let monomorphize_atom tat = let c = match tat.c with | TAtrue | TAfalse -> tat.c | TAeq tl -> TAeq (List.map mono_term tl) | TAneq tl -> TAneq (List.map mono_term tl) | TAle tl -> TAle (List.map mono_term tl) | TAlt tl -> TAlt (List.map mono_term tl) | TAdistinct tl -> TAdistinct (List.map mono_term tl) | TApred t -> TApred (mono_term t) | TAbuilt (hs, tl) -> TAbuilt(hs, List.map mono_term tl) in { tat with c = c } let monomorphize_var (s,ty) = s, Ty.monomorphize ty let rec monomorphize_form tf = let c = match tf.c with | TFatom tat -> TFatom (monomorphize_atom tat) | TFop (oplogic , tfl) -> TFop(oplogic, List.map monomorphize_form tfl) | TFforall qf -> TFforall { qf_bvars = List.map monomorphize_var qf.qf_bvars; qf_upvars = List.map monomorphize_var qf.qf_upvars; qf_form = monomorphize_form qf.qf_form; qf_triggers = List.map (fun (l, b) -> List.map mono_term l, b) qf.qf_triggers} | TFexists qf -> TFexists { qf_bvars = List.map monomorphize_var qf.qf_bvars; qf_upvars = List.map monomorphize_var qf.qf_upvars; qf_form = monomorphize_form qf.qf_form; qf_triggers = List.map (fun (l, b) -> List.map mono_term l, b) qf.qf_triggers} | TFlet (l, sy, tt, tf) -> let l = List.map monomorphize_var l in TFlet(l,sy, mono_term tt, monomorphize_form tf) | TFnamed (hs,tf) -> TFnamed(hs, monomorphize_form tf) in { tf with c = c } let axioms_of_rules keep_triggers loc name lf acc env = let acc = List.fold_left (fun acc (f, _) -> let f = Triggers.make keep_triggers false f in let name = (Hstring.fresh_string ()) ^ "_" ^ name in let td = {c = TAxiom(loc,name,f); annot = new_id () } in (td, env)::acc ) acc lf in acc, env let type_hypothesis keep_triggers acc env_f loc sort f = let f,_ = type_form env_f f in let f = monomorphize_form f in let f = Triggers.make keep_triggers false f in let td = {c = TAxiom(loc, fresh_hypothesis_name sort,f); annot = new_id () } in (td, env_f)::acc let type_goal keep_triggers acc env_g loc sort n goal = let goal, _ = type_form env_g goal in let goal = monomorphize_form goal in let goal = Triggers.make keep_triggers true goal in let td = {c = TGoal(loc, sort, n, goal); annot = new_id () } in (td, env_g)::acc let rec type_and_intro_goal keep_triggers acc env loc sort n f = let b = (* smtfile() || smt2file() || satmode()*) false in let axioms, (goal, env_g) = intro_hypothesis env (not b) f in let loc = f.pp_loc in let acc = List.fold_left (fun acc (f, env_f) -> match f.pp_desc with | PPcut f -> let acc = type_and_intro_goal keep_triggers acc env_f loc Cut (fresh_cut_name ()) f in type_hypothesis keep_triggers acc env_f loc sort f | PPcheck f -> type_and_intro_goal keep_triggers acc env_f loc Check (fresh_check_name ()) f | _ -> type_hypothesis keep_triggers acc env_f loc sort f ) acc axioms in type_goal keep_triggers acc env_g loc sort n goal let type_decl keep_triggers (acc, env) d = Types.to_tyvars := MString.empty; try match d with | Logic (loc, ac, lp, pp_ty) -> Options.tool_req 1 "TR-Typing-LogicFun$_F$"; let env' = Env.add_logics env ac lp pp_ty loc in let lp = List.map fst lp in let td = {c = TLogic(loc,lp,pp_ty); annot = new_id () } in (td, env)::acc, env' | Axiom(loc,name,f) -> Options.tool_req 1 "TR-Typing-AxiomDecl$_F$"; let f, _ = type_form env f in let f = Triggers.make keep_triggers false f in let td = {c = TAxiom(loc,name,f); annot = new_id () } in (td, env)::acc, env | Rewriting(loc, name, lr) -> let lf = List.map (type_form env) lr in if Options.rewriting () then let rules = List.map (fun (f,_) -> make_rules loc f) lf in let td = {c = TRewriting(loc, name, rules); annot = new_id () } in (td, env)::acc, env else axioms_of_rules keep_triggers loc name lf acc env | Goal(loc, n, f) -> Options.tool_req 1 "TR-Typing-GoalDecl$_F$"; (*let f = move_up f in*) let f = alpha_renaming_env env f in type_and_intro_goal keep_triggers acc env loc Thm n f, env | Predicate_def(loc,n,l,e) | Function_def(loc,n,l,_,e) -> check_duplicate_params l; let ty = let l = List.map (fun (_,_,x) -> x) l in match d with Function_def(_,_,_,t,_) -> PFunction(l,t) | _ -> PPredicate l in let l = List.map (fun (_,x,t) -> (x,t)) l in let env = Env.add_logics env Symbols.Other [n] ty loc in (* TODO *) let n = fst n in let lvar = List.map (fun (x,_) -> {pp_desc=PPvar x;pp_loc=loc}) l in let p = {pp_desc=PPapp(n,lvar) ; pp_loc=loc } in let infix = match d with Function_def _ -> PPeq | _ -> PPiff in let f = { pp_desc = PPinfix(p,infix,e) ; pp_loc = loc } in (* le trigger [[p]] ne permet pas de replier la definition, donc on calcule les termes maximaux de la definition pour laisser une possibilite de replier *) let trs = max_terms e in let f = make_pred loc [[p], false ; trs, false] f l in let f,_ = type_form env f in let f = Triggers.make keep_triggers false f in let td = match d with | Function_def(_,_,_,t,_) -> Options.tool_req 1 "TR-Typing-LogicFun$_F$"; TFunction_def(loc,n,l,t,f) | _ -> Options.tool_req 1 "TR-Typing-LogicPred$_F$"; TPredicate_def(loc,n,l,f) in let td_a = { c = td; annot=new_id () } in (td_a, env)::acc, env | TypeDecl(loc, ls, s, body) -> Options.tool_req 1 "TR-Typing-TypeDecl$_F$"; let env1 = Env.add_type_decl env ls s body loc in let td1 = TTypeDecl(loc, ls, s, body) in let td1_a = { c = td1; annot=new_id () } in let tls = List.map (fun s -> PPTvarid (s,loc)) ls in let ty = PFunction([], PPTexternal(tls, s, loc)) in match body with | Enum lc -> let lcl = List.map (fun c -> c, "") lc in (* TODO change this *) let env2 = Env.add_logics env1 Symbols.Constructor lcl ty loc in let td2 = TLogic(loc, lc, ty) in let td2_a = { c = td2; annot=new_id () } in (td1_a, env1)::(td2_a,env2)::acc, env2 | _ -> (td1_a, env1)::acc, env1 with Warning(e,loc) -> Loc.report std_formatter loc; acc, env let file keep_triggers env ld = let ltd, env = List.fold_left (fun acc d -> type_decl keep_triggers acc d) ([], env) ld in List.rev ltd, env let is_local_hyp s = try Pervasives.(=) (String.sub s 0 2) "@L" with Invalid_argument _ -> false let is_global_hyp s = try Pervasives.(=) (String.sub s 0 2) "@H" with Invalid_argument _ -> false let split_goals l = let _, _, _, ret = List.fold_left (fun (ctx, global_hyp, local_hyp, ret) ( (td, env) as x) -> match td.c with | TGoal (_, (Check | Cut), _, _) -> ctx, global_hyp, [], (x::(local_hyp@global_hyp@ctx))::ret | TGoal (_, _, _, _) -> ctx, [], [], (x::(local_hyp@global_hyp@ctx))::ret | TAxiom (_, s, _) when is_global_hyp s -> ctx, x::global_hyp, local_hyp, ret | TAxiom (_, s, _) when is_local_hyp s -> ctx, global_hyp, x::local_hyp, ret | _ -> x::ctx, global_hyp, local_hyp, ret ) ([],[],[],[]) l in List.rev_map List.rev ret let term env vars t = let vmap = List.fold_left (fun m (s,ty)-> let str = Symbols.to_string_clean s in MString.add str (s,ty) m ) env.Env.var_map vars in let env = { env with Env.var_map = vmap } in type_term env t type env = Env.t let empty_env = Env.empty alt-ergo-1.30/src/preprocess/triggers.ml0000644000175000001440000006323613014515065016661 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format open Typed module Sy = Symbols type polarity = Pos | Neg module Vterm = Sy.Set module Vtype = Set.Make(struct type t=int let compare=Pervasives.compare end) module STRS = Set.Make( struct type t = (int tterm, int) annoted * Vterm.t * Vtype.t let rec compare_term t1 t2 = match t1.c.tt_desc, t2.c.tt_desc with | TTvar s1 , TTvar s2 -> Sy.compare s1 s2 | TTapp (s1,l1) , TTapp(s2,l2) -> let c = Sy.compare s1 s2 in if c=0 then compare_list l1 l2 else c | TTinfix(a1,s1,b1) , TTinfix(a2,s2,b2) -> let c = Sy.compare s1 s2 in if c=0 then let c=compare_term a1 a2 in if c=0 then compare_term b1 b2 else c else c | TTconst (Treal r1) , TTconst (Treal r2) -> Num.compare_num r1 r2 | x , y -> Pervasives.compare x y and compare_list l1 l2 = match l1,l2 with [] , _ -> -1 | _ , [] -> 1 | x::l1 , y::l2 -> let c = Pervasives.compare x y in if c=0 then compare_list l1 l2 else c let compare (t1,_,_) (t2,_,_) = compare_term t1 t2 end) let sort = List.sort (fun l1 l2 -> compare (List.length l1) (List.length l2)) let neg_pol x = x (*function Pos -> Neg | Neg -> Pos*) let compare_tconstant c1 c2 = match c1, c2 with | Tint s1, Tint s2 -> String.compare s1 s2 | Tint s1, _ -> 1 | _, Tint s1 -> -1 | Treal s1, Treal s2 -> Num.compare_num s1 s2 | Treal s1, _ -> 1 | _, Treal s2 -> -1 | Tbitv s1, Tbitv s2 -> String.compare s1 s2 | Tbitv s1, _ -> 1 | _, Tbitv s2 -> -1 | _ -> Pervasives.compare c1 c2 let rec depth_tterm t = match t.c.tt_desc with | TTconst _ | TTvar _-> 0 | TTapp (_, tl) -> 1 + (List.fold_left (fun acc t -> max (depth_tterm t) acc) 0 tl) | TTinfix _ | TTprefix _ -> 0 (* arithmetic triggers are not suitable *) | TTget (t1, t2) | TTconcat (t1, t2) -> max (depth_tterm t1) (depth_tterm t2) | TTdot(t, _) -> 1 + depth_tterm t | TTrecord lbs -> 1 + (List.fold_left (fun acc (lb, t) -> max (depth_tterm t) acc) 0 lbs) | TTset (t1, t2, t3) | TTextract (t1, t2, t3) -> max (depth_tterm t1) (max (depth_tterm t2) (depth_tterm t3)) | TTlet (s, t1, t2) -> max (depth_tterm t1 + 1) (depth_tterm t2) | TTnamed (_, t) -> depth_tterm t exception Out of int (* pourquoi cette fonction de comparaison est-elle si compliquee? *) let rec compare_tterm t1 t2 = match t1.c.tt_desc, t2.c.tt_desc with | TTconst c1, TTconst c2 -> compare_tconstant c1 c2 | TTconst _, _ -> -1 | _, TTconst _ -> 1 | TTvar v1, TTvar v2 -> Sy.compare v1 v2 | TTvar _, _ -> -1 | _, TTvar _ -> 1 | TTinfix (tu1, s, tu2), TTinfix (tu1', s', tu2') -> let c = (depth_tterm t1) - (depth_tterm t2) in if c <> 0 then c else let c = Sy.compare s s' in if c <> 0 then c else let c = compare_tterm tu1 tu1' in if c <> 0 then c else compare_tterm tu2 tu2' | TTinfix _, _ -> -1 | _, TTinfix _ -> 1 | TTprefix (s1, t1), TTprefix (s2, t2) -> let c = Sy.compare s1 s2 in if c<>0 then c else compare_tterm t1 t2 | TTprefix _, _ -> -1 | _, TTprefix _ -> 1 | TTapp (s1, tl1), TTapp (s2, tl2) -> let l1 = List.map depth_tterm tl1 in let l2 = List.map depth_tterm tl2 in let l1 = List.fast_sort compare l1 in let l2 = List.fast_sort compare l2 in let c = try List.iter2 (fun n m -> if n <> m then raise (Out (n-m)) ) l1 l2; 0 with | Out c -> c | _ -> (List.length l1) - (List.length l2) in if c <> 0 then c else let c = Sy.compare s1 s2 in if c <> 0 then c else begin try List.iter2 (fun t1 t2 -> let c = compare_tterm t1 t2 in if c <> 0 then raise (Out c) ) tl1 tl2; 0 with Out c -> c end | TTapp _, _ -> -1 | _, TTapp _ -> 1 | TTget (t1, t2), TTget (u1, u2) -> let c = compare_tterm t1 u1 in if c<>0 then c else compare_tterm t2 u2 | TTget _, _ -> -1 | _, TTget _ -> 1 | TTset(t1, t2, t3) , TTset(u1, u2, u3) -> let c = compare_tterm t1 u1 in if c<>0 then c else let c = compare_tterm t2 u2 in if c<>0 then c else compare_tterm t3 u3 | TTset _, _ -> -1 | _, TTset _ -> 1 | TTextract(t1, t2, t3) , TTextract(u1, u2, u3) -> let c = compare_tterm t1 u1 in if c<>0 then c else let c = compare_tterm t2 u2 in if c<>0 then c else compare_tterm t3 u3 | TTextract _, _ -> -1 | _, TTextract _ -> 1 | TTconcat (t1, t2), TTconcat (u1, u2) -> let c = compare_tterm t1 u1 in if c<>0 then c else compare_tterm t2 u2 | TTconcat _, _ -> -1 | _, TTconcat _ -> 1 | TTdot(t1, a1), TTdot(t2,a2) -> let c = Pervasives.compare a1 a2 in if c<>0 then c else compare_tterm t1 t2 | TTdot _, _ -> -1 | _, TTdot _ -> 1 | TTrecord lbs1, TTrecord lbs2 -> let s1 = List.length lbs1 in let s2 = List.length lbs2 in let c = compare s1 s2 in if c <> 0 then c else begin try List.iter2 (fun (lb1, t1) (lb2, t2) -> let c = Hstring.compare lb1 lb2 in if c<>0 then raise (Out c); let c = compare_tterm t1 t2 in if c<>0 then raise (Out c)) lbs1 lbs2; 0 with Out n -> n end | TTrecord _, _ -> -1 | _, TTrecord _ -> 1 | TTlet (s1, t1, u1) , TTlet (s2, t2, u2) -> let c = Sy.compare s1 s2 in if c<>0 then c else let c = compare_tterm t1 u1 in if c<>0 then c else compare_tterm u1 u2 | TTnamed (_, t), _ -> compare_tterm t t2 | _, TTnamed (_, t) -> compare_tterm t1 t let compare_tterm_list tl2 tl1 = let l1 = List.map depth_tterm tl1 in let l2 = List.map depth_tterm tl2 in let l1 = List.rev (List.fast_sort compare l1) in let l2 = List.rev (List.fast_sort compare l2) in let c = try List.iter2 (fun n m -> if n <> m then raise (Out (n-m)) ) l1 l2; 0 with | Out c -> c | _ -> (List.length l2) - (List.length l1) in if c <> 0 then c else begin try List.iter2 (fun t1 t2 -> let c = compare_tterm t1 t2 in if c <> 0 then raise (Out c) ) tl1 tl2; 0 with Out c -> c end module Uniq_sort = struct let rec merge cmp l1 l2 = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> let c = cmp h1 h2 in if c = 0 then h1 :: merge cmp t1 t2 else if c < 0 then h1 :: merge cmp t1 l2 else h2 :: merge cmp l1 t2 let rec chop k l = if k = 0 then l else begin match l with | x::t -> chop (k-1) t | _ -> assert false end ;; let stable_sort cmp l = let rec rev_merge l1 l2 accu = match l1, l2 with | [], l2 -> List.rev_append l2 accu | l1, [] -> List.rev_append l1 accu | h1::t1, h2::t2 -> let c = cmp h1 h2 in if c = 0 then rev_merge t1 t2 (h1::accu) else if c < 0 then rev_merge t1 l2 (h1::accu) else rev_merge l1 t2 (h2::accu) in let rec rev_merge_rev l1 l2 accu = match l1, l2 with | [], l2 -> List.rev_append l2 accu | l1, [] -> List.rev_append l1 accu | h1::t1, h2::t2 -> let c = cmp h1 h2 in if c = 0 then rev_merge_rev t1 t2 (h1::accu) else if c > 0 then rev_merge_rev t1 l2 (h1::accu) else rev_merge_rev l1 t2 (h2::accu) in let rec sort n l = match n, l with | 2, x1 :: x2 :: _ -> let c = cmp x1 x2 in if c = 0 then [x1] else if c < 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> let c = cmp x1 x2 in if c = 0 then begin let c = cmp x2 x3 in if c = 0 then [x1] else if c <= 0 then [x1; x3] else [x3; x1] end else if c < 0 then begin let c = cmp x2 x3 in if c = 0 then [x1; x2] else if c < 0 then [x1; x2; x3] else let c = cmp x1 x3 in if c = 0 then [x1; x2] else if c < 0 then [x1; x3; x2] else [x3; x1; x2] end else begin let c = cmp x1 x3 in if c = 0 then [x2; x1] else if c < 0 then [x2; x1; x3] else let c = cmp x2 x3 in if c = 0 then [x2; x1] else if c < 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = rev_sort n1 l in let s2 = rev_sort n2 l2 in rev_merge_rev s1 s2 [] and rev_sort n l = match n, l with | 2, x1 :: x2 :: _ -> let c = cmp x1 x2 in if c = 0 then [x1] else if c > 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> let c = cmp x1 x2 in if c = 0 then begin let c = cmp x2 x3 in if c = 0 then [x1] else if c > 0 then [x1; x3] else [x3; x1] end else if c > 0 then begin let c = cmp x2 x3 in if c = 0 then [x1; x2] else if c > 0 then [x1; x2; x3] else let c = cmp x1 x3 in if c = 0 then [x1; x2] else if c > 0 then [x1; x3; x2] else [x3; x1; x2] end else begin let c = cmp x1 x3 in if c = 0 then [x2; x1] else if c > 0 then [x2; x1; x3] else let c = cmp x2 x3 in if c = 0 then [x2; x1] else if c > 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = sort n1 l in let s2 = sort n2 l2 in rev_merge s1 s2 [] in let len = List.length l in if len < 2 then l else sort len l end let at_most n l = let l = Uniq_sort.stable_sort compare_tterm_list l in let rec atmost acc n l = match n, l with | n, _ when n <= 0 -> acc | _ , [] -> acc | n, x::l -> if List.mem x acc then atmost acc n l else atmost (x::acc) (n-1) l in List.rev (atmost [] n l) let is_var t = match t.c.tt_desc with | TTvar (Sy.Var _) -> true | _ -> false (* constant terms such as "logic nil : 'a list" are allowed in triggers *) module SLLT = Set.Make( struct type t = (int tterm, int) annoted list * Vterm.t * Vtype.t let compare (_, y1, _) (_, y2, _) = Vterm.compare y1 y2 end) let parties bv vty l = let l = if triggers_var () then l else List.filter (fun (t,_,_) -> not (is_var t)) l in let rec parties_rec (llt, llt_ok) l = match l with | [] -> llt_ok | (t, bv1, vty1)::l -> let llt, llt_ok = SLLT.fold (fun (l, bv2, vty2) (llt, llt_ok) -> let bv3 = Vterm.union bv2 bv1 in let vty3 = Vtype.union vty2 vty1 in let e = t::l, bv3, vty3 in if Vterm.subset bv bv3 && Vtype.subset vty vty3 then llt, SLLT.add e llt_ok else SLLT.add e llt, llt_ok) llt (llt, llt_ok) in parties_rec (SLLT.add ([t], bv1, vty1) llt, llt_ok) l in SLLT.elements (parties_rec (SLLT.empty, SLLT.empty) l) let strict_subset bv vty = List.exists (fun (_, bv',vty') -> (Vterm.subset bv bv' && not(Vterm.equal bv bv') && Vtype.subset vty vty') || (Vtype.subset vty vty' && not(Vtype.equal vty vty') && Vterm.subset bv bv') ) let simplification bv_a vty_a = let rec simpl_rec acc = function | [] -> acc | ((t, bv, vty) as e)::l -> if strict_subset bv vty l || strict_subset bv vty acc || (Vterm.subset bv_a bv && Vtype.subset vty_a vty) || (Vterm.equal (Vterm.inter bv_a bv) Vterm.empty && Vtype.equal (Vtype.inter vty_a vty) Vtype.empty) then simpl_rec acc l else simpl_rec (e::acc) l in simpl_rec [] let rec vars_of_term bv acc t = match t.c.tt_desc with | TTvar x -> if Vterm.mem x bv then Vterm.add x acc else acc | TTapp (_,lt) -> List.fold_left (vars_of_term bv) acc lt | TTinfix (t1,_,t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTset (t1, t2, t3) -> List.fold_left (vars_of_term bv) acc [t1;t2;t3] | TTget (t1, t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTlet (_, t1, t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTdot (t1, _) -> vars_of_term bv acc t1 | TTrecord lbs -> List.fold_left (fun acc (_, t) -> vars_of_term bv acc t) acc lbs | TTprefix (_, t) -> vars_of_term bv acc t | TTnamed (_, t) -> vars_of_term bv acc t | TTextract (t1, t2, t3) -> List.fold_left (vars_of_term bv) acc [t1;t2;t3] | TTconcat (t1, t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTconst _ -> acc let underscoring_term mvars underscores t = let rec under_rec t = { t with c={ t.c with tt_desc = under_rec_desc t.c.tt_desc}} and under_rec_desc t = match t with | TTvar x when Vterm.mem x mvars -> if not (Vterm.mem x !underscores) then ( underscores := Vterm.add x !underscores; t) else TTvar (Sy.underscoring x) | TTvar _ -> t | TTapp (s,lt) -> TTapp(s,List.map under_rec lt) | TTinfix (t1,op,t2) -> TTinfix(under_rec t1,op,under_rec t2) (* XXX TTlet ? *) | _ -> t in under_rec t let underscoring_mt bv mt = let vars , mvars = List.fold_left (fun (vars, mvars) t -> let vs = vars_of_term bv Vterm.empty t in let mvars = Vterm.union mvars (Vterm.inter vars vs) in Vterm.union vars vs , mvars) (Vterm.empty,Vterm.empty) mt in let underscores = ref Vterm.empty in List.map (underscoring_term mvars underscores) mt let multi_triggers gopt bv vty trs = let terms = simplification bv vty trs in let l_parties = parties bv vty terms in let lm = List.map (fun (lt, _, _) -> lt) l_parties in let mv , mt = List.partition (List.exists is_var) lm in let mv , mt = sort mv , sort mt in let lm = if gopt || triggers_var () then mt@mv else mt in let m = at_most (nb_triggers ()) lm in at_most (nb_triggers ()) m let rec vty_ty acc t = let t = Ty.shorten t in match t with | Ty.Tvar { Ty.v = i; value = None } -> Vtype.add i acc | Ty.Text(l,_) -> List.fold_left vty_ty acc l | Ty.Tfarray (t1,t2) -> vty_ty (vty_ty acc t1) t2 | Ty.Trecord {Ty.args = args; lbs = lbs} -> let acc = List.fold_left vty_ty acc args in List.fold_left (fun acc (_, t) -> vty_ty acc t) acc lbs | _ -> acc let rec vty_term acc t = let acc = vty_ty acc t.c.tt_ty in match t.c.tt_desc with | TTapp (_,l) -> List.fold_left vty_term acc l | TTinfix (t1,_,t2) -> vty_term (vty_term acc t1) t2 | TTset (t1, t2, t3) -> List.fold_left vty_term acc [t1;t2;t3] | TTget (t1, t2) -> List.fold_left vty_term acc [t1;t2] | TTdot (t1, _) -> vty_term acc t1 | TTrecord lbs -> List.fold_left (fun acc (_, t) -> vty_term acc t) acc lbs | TTlet (_, t1, t2) -> List.fold_left vty_term acc [t1;t2] | _ -> acc let rec vty_form acc f = match f.c with | TFatom {c=(TAeq l | TAneq l | TAdistinct l | TAle l | TAlt l | TAbuilt(_,l))}-> List.fold_left vty_term acc l | TFatom {c=TApred t} -> vty_term acc t | TFop(_,l) -> List.fold_left vty_form acc l | TFforall qf | TFexists qf -> let acc = List.fold_left (fun acc (_, ty) -> vty_ty acc ty) acc qf.qf_bvars in vty_form acc qf.qf_form | TFnamed (_, f) -> vty_form acc f | TFlet (ls, s, e, f') -> vty_form (vty_term acc e) f' | _ -> acc let csort = Sy.name "c_sort" let filter_mono vterm vtype (t, bv_t, vty_t) = Vterm.subset vterm bv_t && Vtype.subset vtype vty_t && match t.c.tt_desc with | TTapp(s, _) -> not (Sy.equal s csort) | _ -> true let as_bv bv s = not (Vterm.is_empty (Vterm.inter bv s)) let as_tyv vty s = not (Vtype.is_empty (Vtype.inter vty s)) let potential_triggers = let rec potential_rec ( (bv, vty) as vars) acc t = let vty_t = vty_term Vtype.empty t in match t.c.tt_desc with | TTvar x -> if Vterm.mem x bv || as_tyv vty vty_t then STRS.add (t, Vterm.singleton x, vty_t) acc else acc | TTapp(s, lf) when Sy.equal s Sy.fake_eq || Sy.equal s Sy.fake_neq || Sy.equal s Sy.fake_lt || Sy.equal s Sy.fake_le -> let vty_lf = List.fold_left vty_term vty_t lf in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty lf in if as_bv bv bv_lf || as_tyv vty vty_lf then let csts = List.filter (fun f -> not (as_bv bv (vars_of_term bv Vterm.empty f)) && not (as_tyv vty (vty_term vty f))) lf in let lf' = lf@csts in let t = { t with c = {t.c with tt_desc = TTapp(s, lf')}} in List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) lf else acc | TTapp(s,lf)-> let vty_lf = List.fold_left vty_term vty_t lf in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty lf in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) lf else acc | TTinfix(t1,_,t2) | TTlet (_, t1, t2) -> (* XXX TTlet ? *) let vty_lf = List.fold_left vty_term vty_t [t1;t2] in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty [t1;t2] in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) [t1;t2] else acc | TTset (t1, t2, t3) -> let vty_lf = List.fold_left vty_term vty_t [t1;t2;t3] in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty [t1;t2;t3] in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) [t1;t2;t3] else acc | TTget (t1, t2) -> let vty_lf = List.fold_left vty_term vty_t [t1;t2] in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty [t1;t2] in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) [t1;t2] else acc | TTdot (t1 , a) -> let vty_lf = vty_term vty_t t1 in let bv_lf = vars_of_term bv Vterm.empty t1 in if as_bv bv bv_lf || as_tyv vty vty_lf then potential_rec vars (STRS.add (t, bv_lf, vty_lf) acc) t1 else acc | TTrecord lbs -> let lt = List.map snd lbs in let vty_lf = List.fold_left vty_term vty_t lt in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty lt in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) lt else acc | _ -> acc in fun vars -> List.fold_left (potential_rec vars) STRS.empty let filter_good_triggers (bv, vty) = List.filter (fun (l, _) -> let s1 = List.fold_left (vars_of_term bv) Vterm.empty l in let s2 = List.fold_left vty_term Vtype.empty l in Vterm.subset bv s1 && Vtype.subset vty s2 ) let make_triggers gopt vterm vtype trs = let l = match List.filter (filter_mono vterm vtype) trs with | [] -> multi_triggers gopt vterm vtype trs | trs' -> let f l = at_most (nb_triggers ()) (List.map (fun (t, _, _) -> [t]) l) in let trs_v, trs_nv = List.partition (fun (t, _, _) -> is_var t) trs' in let ll = if trs_nv == [] then if triggers_var () || gopt then f trs_v else [] (*multi_triggers vars trs*) else f trs_nv in if greedy () || gopt then ll@(multi_triggers gopt vterm vtype trs) else ll in Lists.rrmap (fun e -> e, false) l let check_triggers trs (bv, vty) = if trs == [] then failwith "There should be a trigger for every quantified formula in a theory."; List.iter (fun (l, _) -> let s1 = List.fold_left (vars_of_term bv) Vterm.empty l in let s2 = List.fold_left vty_term Vtype.empty l in if not (Vtype.subset vty s2) || not (Vterm.subset bv s1) then failwith "Triggers of a theory should contain every quantified types and variables.") trs; trs let rec make_rec keep_triggers pol gopt vterm vtype f = let c, trs = match f.c with | TFatom {c = (TAfalse | TAtrue)} -> f.c, STRS.empty | TFatom a -> if Vterm.is_empty vterm && Vtype.is_empty vtype then f.c, STRS.empty else begin let l = match a.c with | TAeq l when pol == Neg -> let v = {tt_desc = TTapp(Sy.fake_eq, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAneq ([t1; t2] as l) when pol == Neg -> let v = { tt_desc = TTapp(Sy.fake_neq, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAle l when pol == Neg -> let v = { tt_desc = TTapp(Sy.fake_le, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAlt l when pol == Neg -> let v = { tt_desc = TTapp(Sy.fake_lt, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAle l | TAlt l | TAeq l | TAneq l | TAbuilt(_,l) -> l | TApred t -> [t] | _ -> assert false in f.c, potential_triggers (vterm, vtype) l end | TFop (OPimp, [f1; f2]) -> let f1, trs1 = make_rec keep_triggers (neg_pol pol) gopt vterm vtype f1 in let f2, trs2 = make_rec keep_triggers pol gopt vterm vtype f2 in let trs = STRS.union trs1 trs2 in TFop(OPimp, [f1; f2]), trs | TFop (OPnot, [f1]) -> let f1, trs1 = make_rec keep_triggers (neg_pol pol) gopt vterm vtype f1 in TFop(OPnot, [f1]), trs1 (* | OPiff | OPif of ('a tterm, 'a) annoted *) | TFop (op, lf) -> let lf, trs = List.fold_left (fun (lf, trs1) f -> let f, trs2 = make_rec keep_triggers pol gopt vterm vtype f in f::lf, STRS.union trs1 trs2) ([], STRS.empty) lf in TFop(op,List.rev lf), trs | TFforall ({ qf_form= {c = TFop(OPiff,[{c=TFatom _} as f1;f2]); annot = ido}} as qf) -> let vtype' = vty_form Vtype.empty qf.qf_form in let vterm' = List.fold_left (fun b (s,_) -> Vterm.add s b) Vterm.empty qf.qf_bvars in let vterm'' = Vterm.union vterm vterm' in let vtype'' = Vtype.union vtype vtype' in let f1', trs1 = make_rec keep_triggers pol gopt vterm'' vtype'' f1 in let f2', trs2 = make_rec keep_triggers pol gopt vterm'' vtype'' f2 in let trs12 = if keep_triggers then check_triggers qf.qf_triggers (vterm', vtype') else if Options.notriggers () || qf.qf_triggers == [] then begin (make_triggers false vterm' vtype' (STRS.elements trs1))@ (make_triggers false vterm' vtype' (STRS.elements trs2)) end else begin let lf = filter_good_triggers (vterm', vtype') qf.qf_triggers in if lf != [] then lf else (make_triggers false vterm' vtype' (STRS.elements trs1))@ (make_triggers false vterm' vtype' (STRS.elements trs2)) end in let trs = STRS.filter (fun (_, bvt, _) -> Vterm.is_empty (Vterm.inter bvt vterm')) (STRS.union trs1 trs2) in let r = { qf with qf_triggers = trs12 ; qf_form = {c=TFop(OPiff,[f1'; f2']); annot = ido} } in begin match f.c with | TFforall _ -> TFforall r, trs | _ -> TFexists r , trs end | TFforall qf | TFexists qf -> let vtype' = vty_form Vtype.empty qf.qf_form in let vterm' = List.fold_left (fun b (s,_) -> Vterm.add s b) Vterm.empty qf.qf_bvars in let f', trs = make_rec keep_triggers pol gopt (Vterm.union vterm vterm') (Vtype.union vtype vtype') qf.qf_form in let trs' = if keep_triggers then check_triggers qf.qf_triggers (vterm', vtype') else if Options.notriggers () || qf.qf_triggers == [] then make_triggers gopt vterm' vtype' (STRS.elements trs) else let lf = filter_good_triggers (vterm',vtype') qf.qf_triggers in if lf != [] then lf else make_triggers gopt vterm' vtype' (STRS.elements trs) in let trs = STRS.filter (fun (_, bvt, _) -> Vterm.is_empty (Vterm.inter bvt vterm')) trs in let r = {qf with qf_triggers = trs' ; qf_form = f'} in (match f.c with | TFforall _ -> TFforall r , trs | _ -> TFexists r , trs) | TFlet (up, v, t, f) -> let f, trs = make_rec keep_triggers pol gopt vterm vtype f in let trs = STRS.union trs (potential_triggers (vterm, vtype) [t]) in (* XXX correct for terms *) TFlet (up, v, t, f), trs | TFnamed(lbl, f) -> let f, trs = make_rec keep_triggers pol gopt vterm vtype f in TFnamed(lbl, f), trs in { f with c = c }, trs let make keep_triggers gopt f = match f.c with | TFforall _ | TFexists _ -> let f, _ = make_rec keep_triggers Pos gopt Vterm.empty Vtype.empty f in f | _ -> let vty = vty_form Vtype.empty f in let f, trs = make_rec keep_triggers Pos gopt Vterm.empty vty f in if Vtype.is_empty vty then f else let trs = STRS.elements trs in if keep_triggers then failwith "No polymorphism in use-defined theories."; let trs = make_triggers gopt Vterm.empty vty trs in { f with c = TFforall {qf_bvars=[]; qf_upvars=[]; qf_triggers=trs; qf_form=f }} alt-ergo-1.30/src/sat/0000755000175000001440000000000013014515065013071 5ustar rtusersalt-ergo-1.30/src/sat/sat_solvers.ml0000644000175000001440000011053113014515065015770 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options open Format module type S = sig type t exception Sat of t exception Unsat of Explanation.t exception I_dont_know of t (* the empty sat-solver context *) val empty : unit -> t val empty_with_inst : (Formula.t -> bool) -> t (* [assume env f] assume a new formula [f] in [env]. Raises Unsat if [f] is unsatisfiable in [env] *) val assume : t -> Formula.gformula -> t (* [pred_def env f] assume a new predicate definition [f] in [env]. *) val pred_def : t -> Formula.t -> string -> Loc.t -> t (* [unsat env f size] checks the unsatisfiability of [f] in [env]. Raises I_dont_know when the proof tree's height reaches [size]. Raises Sat if [f] is satisfiable in [env] *) val unsat : t -> Formula.gformula -> Explanation.t val print_model : header:bool -> Format.formatter -> t -> unit val reset_refs : unit -> unit val get_steps : unit -> int64 (* returns used axioms/predicates * unused axioms/predicates *) val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end (*** Implementation of Dfs_sat ***) module Dfs_sat : S = struct module Th = Theory.Main open Sig module A = Literal module F = Formula module Inst = Instances.Make(Th) module SF = F.Set module MF = F.Map module MA = Literal.LT.Map module Ex = Explanation module H = Hashtbl.Make(Formula) module Heuristics = struct type t = { mp : float MF.t; (* valeur de l'increment pour l'activite des variables *) var_inc : float; (* inverse du facteur d'acitivte des vars, vaut 1/0.999 par defaut *) var_decay : float; } let empty () = { mp = MF.empty; var_inc = 1.; var_decay = 1. /. 0.95; } let bump_activity ({mp=mp;var_inc=var_inc} as env) expl = let stable = ref true in let mp = SF.fold (fun f mp -> let w = var_inc +. try MF.find f mp with Not_found -> 0. in stable := !stable && Pervasives.(<=) w 1e100; MF.add f w mp )(Ex.bj_formulas_of expl) mp in let mp = if !stable then mp else MF.fold (fun f w acc -> MF.add f (w *. 1e-100) acc) mp MF.empty in { env with mp = mp; var_inc = var_inc *. env.var_decay } let choose l0 env = let l = List.rev_map (fun ((a,b,d,is_impl) as e) -> e, (try (MF.find a.F.f env.mp) with Not_found -> 0.), a.F.gf ) l0 in let l = List.fast_sort (fun (_, x1, b1) (_, x2, b2) -> let c = Pervasives.compare b2 b1 in if c <> 0 then c else Pervasives.compare x2 x1 )l in let e, cpt, _ = List.hd l in e, List.rev (List.rev_map (fun (e,_,_) -> e) (List.tl l)) end type t = { (* The field gamma contains the current Boolean model (true formulas) of the SAT. Each assumed formula is mapped to a tuple (gf, ex, dlvl, plvl), where: - gf is the rich form of the formula - ex is the explanation associated to the formula - dlvl is the decision level where the formula was assumed to true - plvl is the propagation level (w.r.t. dlvl) of the formula. It forms with dlvl a total ordering on the formulas in gamma. *) gamma : (F.gformula * Ex.t * int * int) MF.t; tcp_cache : Sig.answer MA.t; delta : (F.gformula * F.gformula * Ex.t * bool) list; dlevel : int; plevel : int; ilevel : int; tbox : Th.t; unit_tbox : Th.t; (* theory env of facts at level 0 *) inst : Inst.t; heuristics : Heuristics.t ref; model_gen_mode : bool ref; ground_preds : F.t A.LT.Map.t; (* key <-> f *) add_inst: Formula.t -> bool; } let steps = ref 0L let all_models_sat_env = ref None let latest_saved_env = ref None let terminated_normally = ref false exception Sat of t exception Unsat of Ex.t exception I_dont_know of t exception IUnsat of Ex.t * Term.Set.t list (*BISECT-IGNORE-BEGIN*) module Debug = struct let propagations (env, bcp, tcp, ap_delta, lits) = if debug_sat() then begin fprintf fmt "[sat] propagations: |lits| = %d , B = %b , T = %b , " (List.length lits) bcp tcp ; fprintf fmt "|Delta| = %d, |ap_Delta| = %d@." (List.length env.delta) (List.length ap_delta) end let is_it_unsat gf = if verbose () && debug_sat () then let s = match F.view gf.F.f with | F.Lemma _ -> "lemma" | F.Clause _ -> "clause" | F.Unit _ -> "conjunction" | F.Skolem _ -> "skolem" | F.Literal _ -> "literal" | F.Let _ -> "let" in fprintf fmt "[sat] the following %s is unsat ? :@.%a@.@." s F.print gf.F.f let pred_def f = if debug_sat () then eprintf "[sat] I assume a predicate: %a@.@." F.print f let unsat_rec dep = if debug_sat () then fprintf fmt "unsat_rec : %a@." Ex.print dep let assume gf dep env = if debug_sat () then let {F.f=f;age=age;lem=lem;mf=mf;from_terms=terms} = gf in fprintf fmt "[sat] at level (%d, %d) I assume a " env.dlevel env.plevel; begin match F.view f with | F.Literal a -> Term.print_list str_formatter terms; let s = flush_str_formatter () in let n = match lem with | None -> "" | Some ff -> (match F.view ff with F.Lemma xx -> xx.F.name | _ -> "") in fprintf fmt "LITERAL (%s : %s) %a@." n s Literal.LT.print a; fprintf fmt "==========================================@.@." | F.Unit _ -> fprintf fmt "conjunction@." | F.Clause _ -> fprintf fmt "clause %a@." F.print f | F.Lemma _ -> fprintf fmt "%d-atom lemma \"%a\"@." (F.size f) F.print f | F.Skolem _ -> fprintf fmt "skolem %a@." F.print f | F.Let {F.let_var=lvar; let_term=lterm; let_f=lf} -> fprintf fmt "let %a = %a in %a@." Symbols.print lvar Term.print lterm F.print lf end; if verbose () then fprintf fmt "with explanations : %a@." Explanation.print dep let unsat () = if debug_sat () then fprintf fmt "[sat] unsat@." let decide f env = if debug_sat () then fprintf fmt "[sat] I decide: at level (%d, %d), on %a@." env.dlevel env.plevel F.print f let instantiate env = if debug_sat () then fprintf fmt "[sat] I instantiate at level (%d, %d). Inst level = %d@." env.dlevel env.plevel env.ilevel let backtracking f env = if debug_sat () then fprintf fmt "[sat] backtrack: at level (%d, %d), and assume not %a@." env.dlevel env.plevel F.print f let backjumping f env = if debug_sat () then fprintf fmt "[sat] backjump: at level (%d, %d), I ignore the case %a@." env.dlevel env.plevel F.print f let elim _ _ = if debug_sat () && verbose () then fprintf fmt "[sat] elim@." let red _ _ = if debug_sat () && verbose () then fprintf fmt "[sat] red@." let delta d = if debug_sat () && verbose () && false then begin fprintf fmt "[sat] - Delta ---------------------@."; List.iter (fun (f1, f2, ex) -> fprintf fmt "(%a or %a), %a@." F.print f1.F.f F.print f2.F.f Ex.print ex) d; fprintf fmt "[sat] --------------------- Delta -@." end let gamma g = if false && debug_sat () && verbose () then begin fprintf fmt "[sat] --- GAMMA ---------------------@."; MF.iter (fun f (_, ex, dlvl, plvl) -> fprintf fmt "(%d, %d) %a \t->\t%a@." dlvl plvl F.print f Ex.print ex) g; fprintf fmt "[sat] - / GAMMA ---------------------@."; end let bottom classes = if bottom_classes () then printf "bottom:%a\n@." Term.print_tagged_classes classes let inconsistent expl env = if debug_sat () then fprintf fmt "inconsistent at level (%d, %d), reason : %a@." env.dlevel env.plevel Ex.print expl end (*BISECT-IGNORE-END*) let selector env f orig = not (MF.mem f env.gamma) && begin match F.view orig with | F.Lemma _ -> env.add_inst orig | _ -> true end let inst_predicates env inst tbox selector ilvl = try Inst.m_predicates inst tbox selector ilvl with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let inst_lemmas env inst tbox selector ilvl = try Inst.m_lemmas inst tbox selector ilvl with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let is_literal f = match F.view f with F.Literal _ -> true | _ -> false let extract_prop_model t = let s = ref SF.empty in MF.iter (fun f _ -> if (complete_model () && is_literal f) || F.is_in_model f then s := SF.add f !s ) t.gamma; !s let print_prop_model fmt s = SF.iter (fprintf fmt "\n %a" F.print) s let print_model ~header fmt t = Format.print_flush (); if header then fprintf fmt "\nModel\n@."; let pm = extract_prop_model t in if not (SF.is_empty pm) then begin fprintf fmt "Propositional:"; print_prop_model fmt pm; fprintf fmt "\n@."; end; Th.print_model fmt t.tbox let _ = if not (model ()) then try Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> Options.exec_timeout ())) with Invalid_argument _ -> () let refresh_model_handler = if model () then fun t -> try Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> printf "%a@." (print_model ~header:true) t; Options.exec_timeout ())) with Invalid_argument _ -> () else fun _ -> () (* sat-solver *) let mk_gf f mf gf = { F.f = f; nb_reductions = 0; trigger_depth = max_int; age= 0; lem= None; from_terms = []; mf= mf; gf= gf } let profile_conflicting_instances exp = if Options.profiling() then SF.iter (fun f -> match F.view f with | F.Lemma {F.name; loc} -> Profiling.conflicting_instance name loc | _ -> () )(Ex.formulas_of exp) let do_case_split env origin = if Options.case_split_policy () == origin then try if debug_sat() then fprintf fmt "[sat] performing case-split@."; let tbox, new_terms = Th.do_case_split env.tbox in let inst=Inst.add_terms env.inst new_terms (mk_gf F.vrai false false) in {env with tbox = tbox; inst = inst} with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) else env let b_elim f env = try let _ = MF.find f env.gamma in Options.tool_req 2 "TR-Sat-Bcp-Elim-1"; if Options.profiling() then Profiling.elim true; true with Not_found -> false let query_of tcp_cache tmp_cache a env = try MA.find a !tcp_cache with Not_found -> try MA.find a !tmp_cache with Not_found -> assert (A.LT.is_ground a); match Th.query a env.tbox with | No -> tmp_cache := MA.add a No !tmp_cache; No | Yes _ as y -> tcp_cache := MA.add a y !tcp_cache; y let th_elim tcp_cache tmp_cache f env = match F.view f with | F.Literal a -> if query_of tcp_cache tmp_cache a env == No then false else begin Options.tool_req 2 "TR-Sat-Bcp-Elim-2"; if Options.profiling() then Profiling.elim false; true end | _ -> false let red tcp_cache tmp_cache f env tcp = let nf = F.mk_not f in try let _, ex, _, _ = MF.find nf env.gamma in let r = Yes (ex, Th.cl_extract env.tbox) in Options.tool_req 2 "TR-Sat-Bcp-Red-1"; r, true with Not_found -> if not tcp then No, false else match F.view nf with | F.Literal a -> let ans = query_of tcp_cache tmp_cache a env in if ans != No then Options.tool_req 2 "TR-Sat-Bcp-Red-2"; ans, false | _ -> No, false let factorize_iff a_t f = let not_at = F.mk_not (F.mk_lit a_t 0) in match F.view f with | F.Unit(f1, f2) -> begin match F.view f1, F.view f2 with | F.Clause(g11, g12, _), F.Clause(g21, g22, _) -> let ng21 = F.mk_not g21 in let ng22 = F.mk_not g22 in assert (F.equal g11 ng21 || F.equal g11 ng22); assert (F.equal g12 ng21 || F.equal g12 ng22); if F.equal g21 not_at then g22 else if F.equal ng21 not_at then F.mk_not g22 else if F.equal g22 not_at then g21 else if F.equal ng22 not_at then F.mk_not g21 else assert false | _ -> assert false end | F.Literal a -> begin match Literal.LT.view a with | Literal.Pred (t, b) -> if b then F.faux else F.vrai | _ -> assert false end | _ -> assert false let pred_def env f name loc = Debug.pred_def f; let t = Term.make (Symbols.name name) [] Ty.Tbool in if not (Term.Set.mem t (F.ground_terms_rec f)) then {env with inst = Inst.add_predicate env.inst (mk_gf f true false)} else begin let a_t = A.LT.mk_pred t false in assert (not (A.LT.Map.mem a_t env.ground_preds)); let f_simpl = factorize_iff a_t f in let gp = A.LT.Map.add a_t f_simpl env.ground_preds in let gp = A.LT.Map.add (A.LT.neg a_t) (F.mk_not f_simpl) gp in {env with ground_preds = gp} end let add_dep f dep = match F.view f with | F.Literal _ when proof () -> if not (Ex.mem (Ex.Bj f) dep) then Ex.union (Ex.singleton (Ex.Dep f)) dep else dep | F.Clause _ when proof () -> Ex.union (Ex.singleton (Ex.Dep f)) dep | _ -> dep let rec add_dep_of_formula f dep = let dep = add_dep f dep in match F.view f with | F.Unit (f1, f2) when proof () -> add_dep_of_formula f2 (add_dep_of_formula f1 dep) | _ -> dep let do_bcp env tcp tcp_cache tmp_cache delta acc = let tcp = tcp && not (Options.no_tcp ()) in List.fold_left (fun (cl,u) ((({F.f=f1} as gf1), ({F.f=f2} as gf2), d, _) as fd) -> Debug.elim gf1 gf2; if b_elim f1 env || b_elim f2 env || (tcp && (th_elim tcp_cache tmp_cache f1 env || th_elim tcp_cache tmp_cache f2 env)) then (cl,u) else begin Debug.red gf1 gf2; match red tcp_cache tmp_cache f1 env tcp, red tcp_cache tmp_cache f2 env tcp with | (Yes (d1, c1), b1) , (Yes (d2, c2), b2) -> if Options.profiling() then Profiling.bcp_conflict b1 b2; let expl = Ex.union (Ex.union d d1) d2 in let c = List.rev_append c1 c2 in raise (Exception.Inconsistent (expl, c)) | (Yes(d1, _), b) , (No, _) -> if Options.profiling() then Profiling.red b; let gf2 = {gf2 with F.nb_reductions = gf2.F.nb_reductions + 1} in cl, (gf2,Ex.union d d1) :: u | (No, _) , (Yes(d2, _),b) -> if Options.profiling() then Profiling.red b; let gf1 = {gf1 with F.nb_reductions = gf1.F.nb_reductions + 1} in cl, (gf1,Ex.union d d2) :: u | (No, _) , (No, _) -> fd::cl , u end ) acc delta let theory_assume env facts = Options.tool_req 2 "TR-Sat-Assume-Lit"; if facts == [] then env else let facts, ufacts, inst, mf, gf = List.fold_left (fun (facts, ufacts, inst, mf, gf) (a, ff, ex, dlvl, plvl) -> assert (A.LT.is_ground a); let facts = (a, ex, dlvl, plvl) :: facts in let ufacts = if Ex.has_no_bj ex then (a, ex, dlvl, plvl) :: ufacts else ufacts in if not ff.F.mf then begin fprintf fmt "%a@." F.print ff.F.f; assert false end; let inst = if ff.F.mf then Inst.add_terms inst (A.LT.terms_nonrec a) ff else inst in facts, ufacts, inst, mf || ff.F.mf, gf || ff.F.gf )([], [], env.inst, false, false) facts in let utbox, _, _ = (* assume unit facts in the theory *) if ufacts != [] && env.dlevel > 0 then try Th.assume ~ordered:false ufacts env.unit_tbox with Exception.Inconsistent (reason, _) as e -> assert (Ex.has_no_bj reason); if Options.profiling() then Profiling.theory_conflict(); if debug_sat() then fprintf fmt "[sat] solved by unit_tbox@."; raise e else env.unit_tbox, Term.Set.empty, 0 in let tbox, new_terms, cpt = try Th.assume facts env.tbox with Exception.Inconsistent _ as e -> if Options.profiling() then Profiling.theory_conflict(); raise e in let utbox = if env.dlevel = 0 then tbox else utbox in let inst = Inst.add_terms inst new_terms (mk_gf F.vrai mf gf) in steps := Int64.add (Int64.of_int cpt) !steps; if steps_bound () <> -1 && Int64.compare !steps (Int64.of_int (steps_bound ())) > 0 then begin printf "Steps limit reached: %Ld@." !steps; exit 1 end; { env with tbox = tbox; unit_tbox = utbox; inst = inst } let propagations ((env, bcp, tcp, ap_delta, lits) as result) = let env = theory_assume env lits in let env = do_case_split env Util.AfterTheoryAssume in Debug.propagations result; let tcp_cache = ref env.tcp_cache in let tmp_cache = ref MA.empty in let acc = if bcp then do_bcp env tcp tcp_cache tmp_cache env.delta ([], []) else env.delta, [] (* no even bcp for old clauses *) in (*both bcp and tcp set to true for new clauses*) let delta, unit = do_bcp env true tcp_cache tmp_cache ap_delta acc in {env with delta = delta; tcp_cache = !tcp_cache}, unit let rec asm_aux acc list = List.fold_left (fun ((env, bcp, tcp, ap_delta, lits) as acc) ({F.f=f} as ff ,dep) -> refresh_model_handler env; Options.exec_thread_yield (); let dep = add_dep f dep in let dep_gamma = add_dep_of_formula f dep in Debug.gamma env.gamma; (try let _, ex_nf, _, _ = MF.find (F.mk_not f) env.gamma in Options.tool_req 2 "TR-Sat-Conflict-1"; if Options.profiling() then Profiling.bool_conflict (); let exx = Ex.union dep_gamma ex_nf in (* missing VSID, but we have regressions when it is activated env.heuristics := Heuristics.bump_activity !(env.heuristics) exx;*) raise (IUnsat (exx, Th.cl_extract env.tbox)) with Not_found -> ()); if MF.mem f env.gamma then begin Options.tool_req 2 "TR-Sat-Remove"; acc end else let env = if ff.F.mf && greedy () then { env with inst= Inst.add_terms env.inst (F.ground_terms_rec f) ff } else env in Debug.assume ff dep env; let env = { env with gamma = MF.add f (ff,dep_gamma,env.dlevel,env.plevel) env.gamma; plevel = env.plevel + 1 } in match F.view f with | F.Unit (f1, f2) -> Options.tool_req 2 "TR-Sat-Assume-U"; let lst = [{ff with F.f=f1},dep ; {ff with F.f=f2},dep] in asm_aux (env, true, tcp, ap_delta, lits) lst | F.Clause(f1,f2,is_impl) -> Options.tool_req 2 "TR-Sat-Assume-C"; let p1 = {ff with F.f=f1} in let p2 = {ff with F.f=f2} in let p1, p2 = if is_impl || F.size f1 <= F.size f2 then p1, p2 else p2, p1 in env, true, tcp, (p1,p2,dep,is_impl)::ap_delta, lits | F.Lemma l -> Options.tool_req 2 "TR-Sat-Assume-Ax"; let inst_env, direct_insts = Inst.add_lemma env.inst ff dep in let env = {env with inst = inst_env} in asm_aux (env, true, tcp, ap_delta, lits) direct_insts | F.Literal a -> let lits = (a, ff, dep, env.dlevel, env.plevel)::lits in let acc = env, true, true, ap_delta, lits in begin try (* ground preds bahave like proxies of lazy CNF *) asm_aux acc [{ff with F.f = A.LT.Map.find a env.ground_preds}, dep] with Not_found -> acc end | F.Skolem quantif -> Options.tool_req 2 "TR-Sat-Assume-Sko"; let f' = F.skolemize quantif in asm_aux (env, true, tcp, ap_delta, lits) [{ff with F.f=f'},dep] | F.Let {F.let_var=lvar; let_term=lterm; let_subst=s; let_f=lf} -> Options.tool_req 2 "TR-Sat-Assume-Let"; let f' = F.apply_subst s lf in let id = F.id f' in let v = Symbols.Map.find lvar (fst s) in let lst = [{ff with F.f=F.mk_lit (A.LT.mk_eq v lterm) id}, dep; {ff with F.f=f'}, dep] in asm_aux (env, true, tcp, ap_delta, lits) lst ) acc list let rec assume env list = if list == [] then env else try let result = asm_aux (env, false, false, [], []) list in let env, list = propagations result in assume env list with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let new_inst_level env = let new_ilevel = env.ilevel + 1 in let env = {env with ilevel = new_ilevel} in if Options.profiling() then Profiling.instantiation new_ilevel; Debug.instantiate env; env (* this function has an internal state used to store the latest generated instances. These instances are used to try to backjump as far as possible using simple "assume"s, ie without decision. The reason for this modification is that a set of instances may cause several conflict, and we don't always detect the one which makes us backjump better. *) let update_instances_cache = let last_cache = ref [] in fun l_opt -> match l_opt with | None -> Some !last_cache (* Get *) | Some l -> (* Set or reset if l = [] *) last_cache := List.filter (fun (_,e) -> Ex.has_no_bj e) l; None (* returns the (new) env and true if some new instances are made *) let inst_and_assume env inst_function inst_env = let gd, ngd = inst_function env inst_env env.tbox (selector env) env.ilevel in let l = List.rev_append (List.rev gd) ngd in if Options.profiling() then Profiling.instances l; match l with | [] -> env, false | _ -> (* Put new generated instances in cache *) ignore (update_instances_cache (Some l)); let env = assume env l in (* No conflict by direct assume, empty cache *) ignore (update_instances_cache (Some [])); env, true let update_all_models_option env = if all_models () then begin (* should be used when all_models () is activated only *) if !all_models_sat_env == None then all_models_sat_env := Some env; let m = MF.fold (fun f _ s -> if is_literal f then SF.add f s else s) env.gamma SF.empty in Format.printf "--- SAT model found ---"; Format.printf "%a@." print_prop_model m; Format.printf "--- / SAT model ---@."; raise (IUnsat (Ex.make_deps m, [])) end let get_all_models_answer () = if all_models () then match !all_models_sat_env with | Some env -> raise (Sat env) | None -> fprintf fmt "[all-models] No SAT models found@." let compute_concrete_model env origin = if abs (interpretation ()) <> origin then env else try (* to push pending stuff *) let env = do_case_split env (Options.case_split_policy ()) in let env = {env with tbox = Th.compute_concrete_model env.tbox} in latest_saved_env := Some env; env with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let return_cached_model return_function = let i = abs(interpretation ()) in assert (i = 1 || i = 2 || i = 3); assert (not !terminated_normally); terminated_normally := true; (* to avoid loops *) begin match !latest_saved_env with | None -> fprintf fmt "[Dfssat] %s%s%s@." "It seems that no model has been computed so for." " You may need to change your model generation strategy" ", or to increase your timeout." | Some env -> let cs_tbox = Th.get_case_split_env env.tbox in let uf = Ccx.Main.get_union_find cs_tbox in Combine.Uf.output_concrete_model uf end; return_function () let () = at_exit (fun () -> let i = abs(interpretation ()) in if not !terminated_normally && (i = 1 || i = 2 || i = 3) then return_cached_model (fun () -> ()) ) let return_answer env orig return_function = update_all_models_option env; let env = compute_concrete_model env orig in let uf = Ccx.Main.get_union_find (Th.get_case_split_env env.tbox) in Options.Time.unset_timeout (); Combine.Uf.output_concrete_model uf; terminated_normally := true; return_function env let switch_to_model_gen env = not !terminated_normally && not !(env.model_gen_mode) && let i = abs (interpretation ()) in (i = 1 || i = 2 || i = 3) let do_switch_to_model_gen env = let i = abs (interpretation ()) in assert (i = 1 || i = 2 || i = 3); if not !(env.model_gen_mode) && Pervasives.(<>) (Options.interpretation_timelimit ()) 0. then begin Options.Time.unset_timeout (); Options.Time.set_timeout (Options.interpretation_timelimit ()); env.model_gen_mode := true; return_answer env i (fun _ -> raise Util.Timeout) end else return_cached_model (fun () -> raise Util.Timeout) let greedy_instantiation env = if greedy () then return_answer env 1 (fun e -> raise (Sat e)); let gre_inst = MF.fold (fun f (gf,_,_,_) inst -> Inst.add_terms inst (F.ground_terms_rec f) gf) env.gamma env.inst in let env = new_inst_level env in let env, new_inst_1 = inst_and_assume env inst_predicates gre_inst in let env, new_inst_2 = inst_and_assume env inst_lemmas gre_inst in let env = do_case_split env Util.AfterMatching in if new_inst_1 || new_inst_2 then env else return_answer env 1 (fun e -> raise (Sat e)) let normal_instantiation env try_greedy = let env = do_case_split env Util.BeforeMatching in let env = compute_concrete_model env 2 in let env = new_inst_level env in let env, new_inst_1 = inst_and_assume env inst_predicates env.inst in let env, new_inst_2 = inst_and_assume env inst_lemmas env.inst in let env = do_case_split env Util.AfterMatching in if new_inst_1 || new_inst_2 then env else if try_greedy then greedy_instantiation env else env let rec unsat_rec env fg is_decision = try let env = assume env [fg] in let env = if is_decision || not (Options.instantiate_after_backjump ()) then env else normal_instantiation env false in back_tracking env with | IUnsat (d, classes) -> profile_conflicting_instances d; Debug.bottom classes; Debug.unsat (); d and back_tracking env = try let env = compute_concrete_model env 3 in if env.delta == [] then back_tracking (normal_instantiation env true) else let ({F.f=f} as a,b,d,is_impl), l = Heuristics.choose env.delta !(env.heuristics) in let new_level = env.dlevel + 1 in if Options.profiling() then Profiling.decision new_level; let env_a = {env with delta=l; dlevel = new_level; plevel = 0} in Debug.decide f env_a; let dep = unsat_rec env_a (a,Ex.singleton (Ex.Bj f)) true in Debug.unsat_rec dep; try let dep' = try Ex.remove (Ex.Bj f) dep with Not_found when Options.no_backjumping() -> dep in Debug.backtracking f env; Options.tool_req 2 "TR-Sat-Decide"; if Options.profiling() then begin Profiling.reset_dlevel env.dlevel; Profiling.reset_ilevel env.ilevel; end; let env = {env with delta=l} in (* in the section below, we try to backjump further with latest generated instances if any *) begin match update_instances_cache None with | None -> assert false | Some [] -> () | Some l -> (* backtrack further if Unsat is raised by the assume below *) ignore (assume env l); (*No backtrack, reset cache*) ignore (update_instances_cache (Some [])); end; unsat_rec (assume env [b, Ex.union d dep']) ({a with F.f=F.mk_not f},dep') false with Not_found -> Debug.backjumping (F.mk_not f) env; Options.tool_req 2 "TR-Sat-Backjumping"; dep with | Util.Timeout when switch_to_model_gen env -> do_switch_to_model_gen env let max_term_depth_in_sat env = let aux mx f = max mx (F.max_term_depth f) in let max_t = MF.fold (fun f _ mx -> aux mx f) env.gamma 0 in A.LT.Map.fold (fun _ f mx -> aux mx f) env.ground_preds max_t let unsat env gf = Debug.is_it_unsat gf; try let env = assume env [gf, Ex.empty] in let env = {env with inst = (* add all the terms of the goal to matching env *) Inst.add_terms env.inst (F.ground_terms_rec gf.F.f) gf} in (* this includes axioms and ground preds but not general predicates *) let max_t = max_term_depth_in_sat env in let env = {env with inst = Inst.register_max_term_depth env.inst max_t} in let env = new_inst_level env in let env, _ = inst_and_assume env inst_predicates env.inst in (* goal directed for lemmas *) let gd, _ = inst_lemmas env env.inst env.tbox (selector env) env.ilevel in if Options.profiling() then Profiling.instances gd; let env = assume env gd in let d = back_tracking env in get_all_models_answer (); terminated_normally := true; d with | IUnsat (dep, classes) -> Debug.bottom classes; Debug.unsat (); get_all_models_answer (); terminated_normally := true; dep | Util.Timeout when switch_to_model_gen env -> do_switch_to_model_gen env let assume env fg = try assume env [fg,Ex.empty] with | IUnsat (d, classes) -> terminated_normally := true; Debug.bottom classes; raise (Unsat d) | Util.Timeout when switch_to_model_gen env -> do_switch_to_model_gen env let unsat env fg = if Options.timers() then try Options.exec_timer_start Timers.M_Sat Timers.F_unsat; let env = unsat env fg in Options.exec_timer_pause Timers.M_Sat Timers.F_unsat; env with e -> Options.exec_timer_pause Timers.M_Sat Timers.F_unsat; raise e else unsat env fg let assume env fg = if Options.timers() then try Options.exec_timer_start Timers.M_Sat Timers.F_assume; let env = assume env fg in Options.exec_timer_pause Timers.M_Sat Timers.F_assume; env with e -> Options.exec_timer_pause Timers.M_Sat Timers.F_assume; raise e else assume env fg let reset_refs () = steps := 0L; all_models_sat_env := None; latest_saved_env := None; terminated_normally := false let empty () = (* initialize some structures in SAT.empty. Otherwise, T.faux is never added as it is replaced with (not T.vrai) *) reset_refs (); let gf_true = mk_gf F.vrai true true in let inst = Inst.empty in let tbox = Th.empty () in let inst = Inst.add_terms inst (Term.Set.singleton Term.vrai) gf_true in let inst = Inst.add_terms inst (Term.Set.singleton Term.faux) gf_true in let tbox = Th.add_term tbox Term.vrai true in let tbox = Th.add_term tbox Term.faux true in let env = { gamma = MF.empty; tcp_cache = MA.empty; delta = [] ; dlevel = 0; plevel = 0; ilevel = 0; tbox = tbox; unit_tbox = tbox; inst = inst; heuristics = ref (Heuristics.empty ()); model_gen_mode = ref false; ground_preds = A.LT.Map.empty; add_inst = fun _ -> true; } in assume env gf_true (*maybe usefull when -no-theory is on*) let empty_with_inst add_inst = { (empty ()) with add_inst = add_inst } let get_steps () = !steps let retrieve_used_context env dep = Inst.retrieve_used_context env.inst dep end let current = ref (module Dfs_sat : S) let initialized = ref false let set_current sat = current := sat let load_current_sat () = match sat_plugin () with | "" -> if debug_sat () then eprintf "[Dynlink] Using Dfs-SAT solver@." | path -> if debug_sat () then eprintf "[Dynlink] Loading the SAT-solver in %s ...@." path; try MyDynlink.loadfile path; if debug_sat () then eprintf "Success !@.@." with | MyDynlink.Error m1 -> if debug_sat() then begin eprintf "[Dynlink] Loading the SAT-solver in plugin \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; let prefixed_path = sprintf "%s/%s" Config.pluginsdir path in if debug_sat () then eprintf "[Dynlink] Loading the SAT-solver in %s ... with prefix %s@." path Config.pluginsdir; try MyDynlink.loadfile prefixed_path; if debug_sat () then eprintf "Success !@.@." with | MyDynlink.Error m2 -> if not (debug_sat()) then begin eprintf "[Dynlink] Loading the SAT-solver in plugin \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; eprintf "[Dynlink] Trying to load the plugin from \"%s\" failed too!@." prefixed_path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m2); exit 1 let get_current () = if not !initialized then begin load_current_sat (); initialized := true; end; !current alt-ergo-1.30/src/sat/sat_solvers.mli0000644000175000001440000000603313014515065016142 0ustar rtusers(******************************************************************************) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2015 --- OCamlPro *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) (******************************************************************************) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (******************************************************************************) open Options module type S = sig type t exception Sat of t exception Unsat of Explanation.t exception I_dont_know of t (* the empty sat-solver context *) val empty : unit -> t val empty_with_inst : (Formula.t -> bool) -> t (* [assume env f] assume a new formula [f] in [env]. Raises Unsat if [f] is unsatisfiable in [env] *) val assume : t -> Formula.gformula -> t (* [pred_def env f] assume a new predicate definition [f] in [env]. *) val pred_def : t -> Formula.t -> string -> Loc.t -> t (* [unsat env f size] checks the unsatisfiability of [f] in [env]. Raises I_dont_know when the proof tree's height reaches [size]. Raises Sat if [f] is satisfiable in [env] *) val unsat : t -> Formula.gformula -> Explanation.t val print_model : header:bool -> Format.formatter -> t -> unit val reset_refs : unit -> unit val get_steps : unit -> int64 (* returns used axioms/predicates * unused axioms/predicates *) val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end (*** Dfs_sat ***) module Dfs_sat : S val get_current : unit -> (module S) (** returns the current activated SAT-solver. The default value is Dfs_sat. When the selected SAT-solver is an external plugin, the first call of this function will attemp to dynamically load it **) val set_current : (module S) -> unit (** sets a new SAT-solver. This function is intended to be used by dynamically loaded plugins **) alt-ergo-1.30/COPYING.md0000644000175000001440000000211713014515065013146 0ustar rtusers## Copyright These software are distributed in the hope that they will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. The resources are licensed as follows: ### The "non-free" Directory Tools and plugins provided in the "non-free" directory are licensed under a Non-Commercial License. You are NOT allowed to redistribute them, to distribute the binaries resulting from their compilation, to modify the licensing, or to use them/the binaries for a commercial purpose without an approval from OCamlPro. See non-free/Non-Commercial-License.pdf for more details. ### The Other Resources The other resources of this software are provided under the CeCILL-C (version 1) license. You can redistribute and/or modify them under the terms of the CeCILL-C FREE SOFTWARE LICENSE AGREEMENT. See enclosed CeCILL-C for more details. Please, do not use enclosed software until you have read and accepted the terms of the licensing above. The use of these software implies that you automatically agree with our terms and conditions.alt-ergo-1.30/Makefile0000644000175000001440000000012213014515065013146 0ustar rtusersinclude Makefile.configurable include Makefile.users -include Makefile.developers alt-ergo-1.30/Makefile.configurable.in0000644000175000001440000000460213014515065016221 0ustar rtusers#****************************************************************************# # The Alt-Ergo theorem prover # # Copyright (C) 2006-2013 # # CNRS - INRIA - Universite Paris Sud # # # # Sylvain Conchon # # Evelyne Contejean # # # # Francois Bobot # # Mohamed Iguernelala # # Stephane Lescuyer # # Alain Mebsout # # # # This file is distributed under the terms of the CeCILL-C licence # #****************************************************************************# # sample Makefile for Objective Caml # Copyright (C) 2001 Jean-Christophe FILLIATRE # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License version 2, as published by the Free Software Foundation. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # # See the GNU Library General Public License version 2 for more details # (enclosed in the file LGPL). # where to install the binaries DESTDIR= prefix=@prefix@ exec_prefix=@exec_prefix@ BINDIR=$(DESTDIR)@bindir@ LIBDIR=$(DESTDIR)@libdir@/alt-ergo PLUGINSDIR=$(LIBDIR)/plugins DATADIR=$(DESTDIR)@datadir@/alt-ergo # where to install the man page MANDIR=$(DESTDIR)@mandir@ # other variables set by ./configure OCAMLC = @OCAMLC@ OCAMLOPT = @OCAMLOPT@ OCAMLDEP = @OCAMLDEP@ OCAMLLEX = @OCAMLLEX@ OCAMLYACC= @OCAMLYACC@ OCAMLBEST = @OCAMLBEST@ OCAMLVERSION = @OCAMLVERSION@ OCAMLWIN32 = @OCAMLWIN32@ EXE = @EXE@ ENABLEGUI = @ENABLEGUI@ ZARITHLIB=@ZARITHLIB@ CAMLZIPLIB=@CAMLZIPLIB@ #OCAMLGRAPHLIB=@OCAMLGRAPHLIB@ LABLGTK2LIB=@LABLGTK2LIB@ OCPLIBSIMPLEXLIB=@OCPLIBSIMPLEXLIB@ alt-ergo-1.30/configure0000755000175000001440000031647013014515065013435 0ustar rtusers#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="src/main/frontend.ml" ac_subst_vars='LTLIBOBJS LIBOBJS EXE OCAMLWIN32 INCLUDEGTK2 ENABLEGUI OCPLIBSIMPLEXLIB LABLGTK2LIB CAMLZIPLIB ZARITHLIB OCAMLLIB OCAMLVERSION OCAMLBEST OCAMLWEB OCAMLYACC OCAMLLEXDOTOPT OCAMLLEX OCAMLDEP OCAMLOPTDOTOPT OCAMLCDOTOPT OCAMLOPT USEOCAMLFIND OCAMLC target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking ' ac_precious_vars='build_alias host_alias target_alias' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Check for Ocaml compilers # we first look for ocamlc in the path; if not present, we fail for ac_prog in ocp-ocamlc ocamlc do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLC"; then ac_cv_prog_OCAMLC="$OCAMLC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLC=$ac_cv_prog_OCAMLC if test -n "$OCAMLC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLC" >&5 $as_echo "$OCAMLC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLC" && break done test -n "$OCAMLC" || OCAMLC="no" if test "$OCAMLC" = no ; then as_fn_error $? "Cannot find ocamlc." "$LINENO" 5 fi # we extract Ocaml version number and library path OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` echo "ocaml version is $OCAMLVERSION" OCAMLLIB=`$OCAMLC -v | tail -1 | cut -f 4 -d " " | tr -d '\\r'` echo "ocaml library path is $OCAMLLIB" SMTPRELUDE="/usr/local/lib/ergo/smt_prelude.mlw" case $OCAMLVERSION in 3.10.1+rc1) as_fn_error $? "Alt-Ergo does not compile with this version of Ocaml" "$LINENO" 5;; esac # we look for ocamlfind; if not present, we just don't use it to find # libraries # Extract the first word of "ocamlfind", so it can be a program name with args. set dummy ocamlfind; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_USEOCAMLFIND+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$USEOCAMLFIND"; then ac_cv_prog_USEOCAMLFIND="$USEOCAMLFIND" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_USEOCAMLFIND="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_USEOCAMLFIND" && ac_cv_prog_USEOCAMLFIND="no" fi fi USEOCAMLFIND=$ac_cv_prog_USEOCAMLFIND if test -n "$USEOCAMLFIND"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $USEOCAMLFIND" >&5 $as_echo "$USEOCAMLFIND" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$USEOCAMLFIND" = yes; then OCAMLFINDLIB=$(ocamlfind printconf stdlib) OCAMLFIND=$(which ocamlfind) if test "$OCAMLFINDLIB" != "$OCAMLLIB"; then USEOCAMLFIND=no; echo "but your ocamlfind is not compatible with your ocamlc:" echo "ocamlfind : $OCAMLFINDLIB, ocamlc : $OCAMLLIB" fi fi #looking for ocamlgraph library #if test "$USEOCAMLFIND" = yes; then # OCAMLGRAPHLIB=$(ocamlfind query -i-format ocamlgraph) #fi # #if test -n "$OCAMLGRAPHLIB";then # echo "ocamlfind found ocamlgraph in $OCAMLGRAPHLIB" # OCAMLGRAPH=yes #else # AC_CHECK_FILE($OCAMLLIB/ocamlgraph/graph.cmi,OCAMLGRAPH=yes,OCAMLGRAPH=no) # if test "$OCAMLGRAPH" = no ; then # AC_CHECK_FILE($OCAMLLIB/graph.cmi,OCAMLGRAPH=yes,OCAMLGRAPH=no) # if test "$OCAMLGRAPH" = no ; then # AC_MSG_ERROR(Cannot find ocamlgraph library. Please install the *libocamlgraph-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://ocamlgraph.lri.fr/*) # else # OCAMLGRAPHLIB="" # fi # else # OCAMLGRAPHLIB="-I +ocamlgraph" # fi #fi #looking for zarith library if test "$USEOCAMLFIND" = yes; then ZARITHLIB=$(ocamlfind query -i-format zarith) fi if test -n "$ZARITHLIB";then echo "ocamlfind found zarith in $ZARITHLIB" ZARITH=yes else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zarith/zarith.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zarith/zarith.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zarith/zarith.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zarith/zarith.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : ZARITH=yes else ZARITH=no fi if test "$ZARITH" = no ; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zarith.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zarith.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zarith.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zarith.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : ZARITH=yes else ZARITH=no fi if test "$ZARITH" = no ; then as_fn_error $? "Cannot find zarith library." "$LINENO" 5 else ZARITHLIB="" fi else ZARITHLIB="-I +zarith" fi fi #looking for camlzip library if test "$USEOCAMLFIND" = yes; then CAMLZIPLIB=$(ocamlfind query -i-format camlzip) fi if test -n "$CAMLZIPLIB";then echo "ocamlfind found camlzip in $CAMLZIPLIB" CAMLZIP=yes else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zip/zip.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zip/zip.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zip/zip.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zip/zip.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : CAMLZIP=yes else CAMLZIP=no fi if test "$CAMLZIP" = no ; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zip.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zip.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zip.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zip.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : CAMLZIP=yes else CAMLZIP=no fi if test "$CAMLZIP" = no ; then as_fn_error $? "Cannot find camlzip library." "$LINENO" 5 else CAMLZIPLIB="" fi else CAMLZIPLIB="-I +zip" fi fi #looking for ocplib-simplex library if test "$USEOCAMLFIND" = yes; then OCPLIBSIMPLEXLIB=$(ocamlfind query -i-format ocplib-simplex) fi if test -n "$OCPLIBSIMPLEXLIB";then echo "ocamlfind found ocplib-simplex in $OCPLIBSIMPLEXLIB" else as_fn_error $? "Cannot find ocplib-simplex library." "$LINENO" 5 fi # then we look for ocamlopt; if not present, we issue a warning # if the version is not the same, we also discard it # we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not for ac_prog in ocp-ocamlopt ocamlopt do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLOPT"; then ac_cv_prog_OCAMLOPT="$OCAMLOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLOPT="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLOPT=$ac_cv_prog_OCAMLOPT if test -n "$OCAMLOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPT" >&5 $as_echo "$OCAMLOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLOPT" && break done test -n "$OCAMLOPT" || OCAMLOPT="no" OCAMLBEST=byte if test "$OCAMLOPT" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamlopt; bytecode compilation only." >&5 $as_echo "$as_me: WARNING: Cannot find ocamlopt; bytecode compilation only." >&2;} else { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlopt version" >&5 $as_echo_n "checking ocamlopt version... " >&6; } TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt discarded." >&6; } OCAMLOPT=no else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLBEST=opt fi fi # checking for ocamlc.opt for ac_prog in ocp-ocamlc.opt ocamlc.opt do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLCDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLCDOTOPT"; then ac_cv_prog_OCAMLCDOTOPT="$OCAMLCDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLCDOTOPT="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLCDOTOPT=$ac_cv_prog_OCAMLCDOTOPT if test -n "$OCAMLCDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLCDOTOPT" >&5 $as_echo "$OCAMLCDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLCDOTOPT" && break done test -n "$OCAMLCDOTOPT" || OCAMLCDOTOPT="no" if test "$OCAMLCDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 $as_echo_n "checking ocamlc.opt version... " >&6; } TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlc.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlc.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLC=$OCAMLCDOTOPT fi fi # checking for ocamlopt.opt if test "$OCAMLOPT" != no ; then for ac_prog in ocp-ocamlopt.opt ocamlopt.opt do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLOPTDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLOPTDOTOPT"; then ac_cv_prog_OCAMLOPTDOTOPT="$OCAMLOPTDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLOPTDOTOPT="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLOPTDOTOPT=$ac_cv_prog_OCAMLOPTDOTOPT if test -n "$OCAMLOPTDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPTDOTOPT" >&5 $as_echo "$OCAMLOPTDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLOPTDOTOPT" && break done test -n "$OCAMLOPTDOTOPT" || OCAMLOPTDOTOPT="no" if test "$OCAMLOPTDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 $as_echo_n "checking ocamlc.opt version... " >&6; } TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVER" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLOPT=$OCAMLOPTDOTOPT fi fi fi # ocamldep, ocamllex and ocamlyacc should also be present in the path # Extract the first word of "ocamldep", so it can be a program name with args. set dummy ocamldep; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLDEP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLDEP"; then ac_cv_prog_OCAMLDEP="$OCAMLDEP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDEP="ocamldep" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLDEP" && ac_cv_prog_OCAMLDEP="no" fi fi OCAMLDEP=$ac_cv_prog_OCAMLDEP if test -n "$OCAMLDEP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEP" >&5 $as_echo "$OCAMLDEP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLDEP" = no ; then as_fn_error $? "Cannot find ocamldep." "$LINENO" 5 fi # Extract the first word of "ocamllex", so it can be a program name with args. set dummy ocamllex; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLLEX+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLLEX"; then ac_cv_prog_OCAMLLEX="$OCAMLLEX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLLEX="ocamllex" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLLEX" && ac_cv_prog_OCAMLLEX="no" fi fi OCAMLLEX=$ac_cv_prog_OCAMLLEX if test -n "$OCAMLLEX"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEX" >&5 $as_echo "$OCAMLLEX" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEX" = no ; then as_fn_error $? "Cannot find ocamllex." "$LINENO" 5 else # Extract the first word of "ocamllex.opt", so it can be a program name with args. set dummy ocamllex.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLLEXDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLLEXDOTOPT"; then ac_cv_prog_OCAMLLEXDOTOPT="$OCAMLLEXDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLLEXDOTOPT="ocamllex.opt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLLEXDOTOPT" && ac_cv_prog_OCAMLLEXDOTOPT="no" fi fi OCAMLLEXDOTOPT=$ac_cv_prog_OCAMLLEXDOTOPT if test -n "$OCAMLLEXDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEXDOTOPT" >&5 $as_echo "$OCAMLLEXDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEXDOTOPT" != no ; then OCAMLLEX=$OCAMLLEXDOTOPT fi fi # Extract the first word of "ocamlyacc", so it can be a program name with args. set dummy ocamlyacc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLYACC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLYACC"; then ac_cv_prog_OCAMLYACC="$OCAMLYACC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLYACC="ocamlyacc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLYACC" && ac_cv_prog_OCAMLYACC="no" fi fi OCAMLYACC=$ac_cv_prog_OCAMLYACC if test -n "$OCAMLYACC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLYACC" >&5 $as_echo "$OCAMLYACC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLYACC" = no ; then as_fn_error $? "Cannot find ocamlyacc." "$LINENO" 5 fi # checking for lablgtk2 if test "$USEOCAMLFIND" = yes; then LABLGTK2LIB=$(ocamlfind query -i-format lablgtk2.sourceview2) fi if test -n "$LABLGTK2LIB";then echo "ocamlfind found lablgtk2.sourceview2 in $LABLGTK2LIB" LABLGTK2=yes ENABLEGUI="yes" else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/lablgtk2/lablgtksourceview2.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/lablgtk2/lablgtksourceview2.cma" >&5 $as_echo_n "checking for $OCAMLLIB/lablgtk2/lablgtksourceview2.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/lablgtk2/lablgtksourceview2.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : LABLGTK2=yes else LABLGTK2=no fi if test "$LABLGTK2" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Will not be able to compile GUI. Please install the *liblablgtksourceview2-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html*" >&5 $as_echo "Will not be able to compile GUI. Please install the *liblablgtksourceview2-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html*" >&6; } else LABLGTK2LIB="-I +lablgtk2" ENABLEGUI="yes" fi fi #When LABLGTK2 is used threads is needed if test -n "$LABLGTK2LIB";then LABLGTK2LIB="$LABLGTK2LIB -I +threads" fi # Extract the first word of "ocamlweb", so it can be a program name with args. set dummy ocamlweb; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLWEB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLWEB"; then ac_cv_prog_OCAMLWEB="$OCAMLWEB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLWEB="ocamlweb" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLWEB" && ac_cv_prog_OCAMLWEB="true" fi fi OCAMLWEB=$ac_cv_prog_OCAMLWEB if test -n "$OCAMLWEB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLWEB" >&5 $as_echo "$OCAMLWEB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # platform { $as_echo "$as_me:${as_lineno-$LINENO}: checking platform" >&5 $as_echo_n "checking platform... " >&6; } if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Win32" >&5 $as_echo "Win32" >&6; } OCAMLWIN32=yes EXE=.exe else OCAMLWIN32=no EXE= fi # substitutions to perform #AC_SUBST(OCAMLGRAPHLIB) # Finally create the Makefile.configurable from Makefile.configurable.in ac_config_files="$ac_config_files Makefile.configurable" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "Makefile.configurable") CONFIG_FILES="$CONFIG_FILES Makefile.configurable" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi chmod a-w Makefile.configurable alt-ergo-1.30/configure.in0000644000175000001440000002331613014515065014031 0ustar rtusers#****************************************************************************# # The Alt-Ergo theorem prover # # Copyright (C) 2006-2013 # # CNRS - INRIA - Universite Paris Sud # # # # Sylvain Conchon # # Evelyne Contejean # # # # Francois Bobot # # Mohamed Iguernelala # # Stephane Lescuyer # # Alain Mebsout # # # # This file is distributed under the terms of the CeCILL-C licence # #****************************************************************************# # # autoconf input for Objective Caml programs # Copyright (C) 2001 Jean-Christophe Filli�tre # from a first script by Georges Mariano # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License version 2, as published by the Free Software Foundation. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # # See the GNU Library General Public License version 2 for more details # (enclosed in the file LGPL). # the script generated by autoconf from this input will set the following # variables: # OCAMLC "ocamlc" if present in the path, or a failure # or "ocamlc.opt" if present with same version number as ocamlc # OCAMLOPT "ocamlopt" (or "ocamlopt.opt" if present), or "no" # OCAMLBEST either "byte" if no native compiler was found, # or "opt" otherwise # OCAMLDEP "ocamldep" # OCAMLLEX "ocamllex" (or "ocamllex.opt" if present) # OCAMLYACC "ocamlyac" # OCAMLLIB the path to the ocaml standard library # OCAMLVERSION the ocaml version number # OCAMLWEB "ocamlweb" (not mandatory) # OCAMLWIN32 "yes"/"no" depending on Sys.os_type = "Win32" # EXE ".exe" if OCAMLWIN32=yes, "" otherwise # check for one particular file of the sources # ADAPT THE FOLLOWING LINE TO YOUR SOURCES! AC_INIT(src/main/frontend.ml) # Check for Ocaml compilers # we first look for ocamlc in the path; if not present, we fail AC_CHECK_PROGS(OCAMLC,ocp-ocamlc ocamlc,no) if test "$OCAMLC" = no ; then AC_MSG_ERROR(Cannot find ocamlc.) fi # we extract Ocaml version number and library path OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` echo "ocaml version is $OCAMLVERSION" OCAMLLIB=`$OCAMLC -v | tail -1 | cut -f 4 -d " " | tr -d '\\r'` echo "ocaml library path is $OCAMLLIB" SMTPRELUDE="/usr/local/lib/ergo/smt_prelude.mlw" case $OCAMLVERSION in 3.10.1+rc1) AC_MSG_ERROR(Alt-Ergo does not compile with this version of Ocaml);; esac # we look for ocamlfind; if not present, we just don't use it to find # libraries AC_CHECK_PROG(USEOCAMLFIND,ocamlfind,yes,no) if test "$USEOCAMLFIND" = yes; then OCAMLFINDLIB=$(ocamlfind printconf stdlib) OCAMLFIND=$(which ocamlfind) if test "$OCAMLFINDLIB" != "$OCAMLLIB"; then USEOCAMLFIND=no; echo "but your ocamlfind is not compatible with your ocamlc:" echo "ocamlfind : $OCAMLFINDLIB, ocamlc : $OCAMLLIB" fi fi #looking for ocamlgraph library #if test "$USEOCAMLFIND" = yes; then # OCAMLGRAPHLIB=$(ocamlfind query -i-format ocamlgraph) #fi # #if test -n "$OCAMLGRAPHLIB";then # echo "ocamlfind found ocamlgraph in $OCAMLGRAPHLIB" # OCAMLGRAPH=yes #else # AC_CHECK_FILE($OCAMLLIB/ocamlgraph/graph.cmi,OCAMLGRAPH=yes,OCAMLGRAPH=no) # if test "$OCAMLGRAPH" = no ; then # AC_CHECK_FILE($OCAMLLIB/graph.cmi,OCAMLGRAPH=yes,OCAMLGRAPH=no) # if test "$OCAMLGRAPH" = no ; then # AC_MSG_ERROR(Cannot find ocamlgraph library. Please install the *libocamlgraph-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://ocamlgraph.lri.fr/*) # else # OCAMLGRAPHLIB="" # fi # else # OCAMLGRAPHLIB="-I +ocamlgraph" # fi #fi #looking for zarith library if test "$USEOCAMLFIND" = yes; then ZARITHLIB=$(ocamlfind query -i-format zarith) fi if test -n "$ZARITHLIB";then echo "ocamlfind found zarith in $ZARITHLIB" ZARITH=yes else AC_CHECK_FILE($OCAMLLIB/zarith/zarith.cma,ZARITH=yes,ZARITH=no) if test "$ZARITH" = no ; then AC_CHECK_FILE($OCAMLLIB/zarith.cma,ZARITH=yes,ZARITH=no) if test "$ZARITH" = no ; then AC_MSG_ERROR(Cannot find zarith library.) else ZARITHLIB="" fi else ZARITHLIB="-I +zarith" fi fi #looking for camlzip library if test "$USEOCAMLFIND" = yes; then CAMLZIPLIB=$(ocamlfind query -i-format camlzip) fi if test -n "$CAMLZIPLIB";then echo "ocamlfind found camlzip in $CAMLZIPLIB" CAMLZIP=yes else AC_CHECK_FILE($OCAMLLIB/zip/zip.cma,CAMLZIP=yes,CAMLZIP=no) if test "$CAMLZIP" = no ; then AC_CHECK_FILE($OCAMLLIB/zip.cma,CAMLZIP=yes,CAMLZIP=no) if test "$CAMLZIP" = no ; then AC_MSG_ERROR(Cannot find camlzip library.) else CAMLZIPLIB="" fi else CAMLZIPLIB="-I +zip" fi fi #looking for ocplib-simplex library if test "$USEOCAMLFIND" = yes; then OCPLIBSIMPLEXLIB=$(ocamlfind query -i-format ocplib-simplex) fi if test -n "$OCPLIBSIMPLEXLIB";then echo "ocamlfind found ocplib-simplex in $OCPLIBSIMPLEXLIB" else AC_MSG_ERROR(Cannot find ocplib-simplex library.) fi # then we look for ocamlopt; if not present, we issue a warning # if the version is not the same, we also discard it # we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not AC_CHECK_PROGS(OCAMLOPT,ocp-ocamlopt ocamlopt,no) OCAMLBEST=byte if test "$OCAMLOPT" = no ; then AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.) else AC_MSG_CHECKING(ocamlopt version) TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then AC_MSG_RESULT(differs from ocamlc; ocamlopt discarded.) OCAMLOPT=no else AC_MSG_RESULT(ok) OCAMLBEST=opt fi fi # checking for ocamlc.opt AC_CHECK_PROGS(OCAMLCDOTOPT,ocp-ocamlc.opt ocamlc.opt,no) if test "$OCAMLCDOTOPT" != no ; then AC_MSG_CHECKING(ocamlc.opt version) TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then AC_MSG_RESULT(differs from ocamlc; ocamlc.opt discarded.) else AC_MSG_RESULT(ok) OCAMLC=$OCAMLCDOTOPT fi fi # checking for ocamlopt.opt if test "$OCAMLOPT" != no ; then AC_CHECK_PROGS(OCAMLOPTDOTOPT,ocp-ocamlopt.opt ocamlopt.opt,no) if test "$OCAMLOPTDOTOPT" != no ; then AC_MSG_CHECKING(ocamlc.opt version) TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVER" != "$OCAMLVERSION" ; then AC_MSG_RESULT(differs from ocamlc; ocamlopt.opt discarded.) else AC_MSG_RESULT(ok) OCAMLOPT=$OCAMLOPTDOTOPT fi fi fi # ocamldep, ocamllex and ocamlyacc should also be present in the path AC_CHECK_PROG(OCAMLDEP,ocamldep,ocamldep,no) if test "$OCAMLDEP" = no ; then AC_MSG_ERROR(Cannot find ocamldep.) fi AC_CHECK_PROG(OCAMLLEX,ocamllex,ocamllex,no) if test "$OCAMLLEX" = no ; then AC_MSG_ERROR(Cannot find ocamllex.) else AC_CHECK_PROG(OCAMLLEXDOTOPT,ocamllex.opt,ocamllex.opt,no) if test "$OCAMLLEXDOTOPT" != no ; then OCAMLLEX=$OCAMLLEXDOTOPT fi fi AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,no) if test "$OCAMLYACC" = no ; then AC_MSG_ERROR(Cannot find ocamlyacc.) fi # checking for lablgtk2 dnl AC_CHECK_PROG(LABLGTK2,lablgtksourceview2,yes,no) dnl if test "$LABLGTK2" = yes ; then dnl if test -e "$OCAMLLIB/lablgtk2/lablgtksourceview2.cmxa" ; then dnl LABLGTK2LIB="-I +lablgtk2" dnl else dnl LABLGTK2LIB dnl fi dnl fi if test "$USEOCAMLFIND" = yes; then LABLGTK2LIB=$(ocamlfind query -i-format lablgtk2.sourceview2) fi if test -n "$LABLGTK2LIB";then echo "ocamlfind found lablgtk2.sourceview2 in $LABLGTK2LIB" LABLGTK2=yes ENABLEGUI="yes" else AC_CHECK_FILE($OCAMLLIB/lablgtk2/lablgtksourceview2.cma,LABLGTK2=yes,LABLGTK2=no) if test "$LABLGTK2" = no ; then AC_MSG_RESULT(Will not be able to compile GUI. Please install the *liblablgtksourceview2-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html*) else LABLGTK2LIB="-I +lablgtk2" ENABLEGUI="yes" fi fi #When LABLGTK2 is used threads is needed if test -n "$LABLGTK2LIB";then LABLGTK2LIB="$LABLGTK2LIB -I +threads" fi AC_CHECK_PROG(OCAMLWEB,ocamlweb,ocamlweb,true) # platform AC_MSG_CHECKING(platform) if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then AC_MSG_RESULT(Win32) OCAMLWIN32=yes EXE=.exe else OCAMLWIN32=no EXE= fi # substitutions to perform AC_SUBST(OCAMLC) AC_SUBST(OCAMLOPT) AC_SUBST(OCAMLDEP) AC_SUBST(OCAMLLEX) AC_SUBST(OCAMLYACC) AC_SUBST(OCAMLBEST) AC_SUBST(OCAMLVERSION) AC_SUBST(OCAMLLIB) #AC_SUBST(OCAMLGRAPHLIB) AC_SUBST(ZARITHLIB) AC_SUBST(CAMLZIPLIB) AC_SUBST(OCAMLWEB) AC_SUBST(LABLGTK2LIB) AC_SUBST(OCPLIBSIMPLEXLIB) AC_SUBST(ENABLEGUI) AC_SUBST(INCLUDEGTK2) AC_SUBST(OCAMLWIN32) AC_SUBST(EXE) # Finally create the Makefile.configurable from Makefile.configurable.in AC_OUTPUT(Makefile.configurable) chmod a-w Makefile.configurable alt-ergo-1.30/README.md0000644000175000001440000000063513014515065012776 0ustar rtusers# Alt-Ergo Alt-Ergo is an automatic theorem prover of mathematical formulas. It was developed at LRI, and is now maintained at OCamlPro: See more details on http://alt-ergo.ocamlpro.com/ ## Copyright See enclosed COPYING.md file ## Build, Installation and Usage See enclosed INSTALL.md file ## Support See http://alt-ergo.ocamlpro.com/support.php or contact us at contact@ocamlpro.com for more details alt-ergo-1.30/Makefile.users0000644000175000001440000002546613014515065014330 0ustar rtusersARCH = $(shell uname -m) VERSION=$(shell grep "=" src/util/version.ml | cut -d"=" -f2 | head -n 1) LOCAL_INC = -I src/util -I src/structures -I src/theories -I src/instances \ -I src/sat -I src/preprocess -I src/parsing -I src/gui -I src/main \ -I non-free/plugins/common -I non-free/plugins/satML -I non-free/plugins/profiler \ -I non-free/plugins/fm-simplex INCLUDES = $(ZARITHLIB) $(LABLGTK2LIB) $(CAMLZIPLIB) $(OCPLIBSIMPLEXLIB) $(LOCAL_INC) #for coverage # -I /usr/local/lib/ocaml/3.12.1/bisect -pp "camlp4o str.cma /usr/local/lib/ocaml/3.12.1/bisect/bisect_pp.cmo" BFLAGS = -annot -absname -bin-annot -short-paths -strict-sequence -g $(INCLUDES) OFLAGS = -annot -absname -bin-annot -short-paths -strict-sequence -g -inline 100 $(INCLUDES) # -for-pack AltErgo BIBBYTE = zarith.cma nums.cma unix.cma dynlink.cma str.cma zip.cma ocplibSimplex.cma # for coverage bisect.cma BIBOPT = $(BIBBYTE:.cma=.cmxa) BIBGUIBYTE = zarith.cma threads.cma lablgtk.cma lablgtksourceview2.cma \ gtkThread.cmo BIBGUIOPT = zarith.cmxa threads.cmxa lablgtk.cmxa lablgtksourceview2.cmxa \ gtkThread.cmx # main target ############# NAME = alt-ergo GUINAME=altgr-ergo LIBNAME = altErgo BYTE=$(NAME).byte OPT=$(NAME).opt ifeq ($(OCAMLBEST),opt) all: opt else all: byte endif GENERATED = src/util/config.ml \ src/parsing/why_parser.ml \ src/parsing/why_parser.mli \ src/parsing/why_lexer.ml # bytecode and native-code compilation ###################################### CMO = src/util/config.cmo \ src/util/version.cmo \ src/util/emap.cmo \ src/util/myUnix.cmo \ src/util/myDynlink.cmo \ src/util/myZip.cmo \ src/util/util.cmo \ src/util/lists.cmo \ src/util/numsNumbers.cmo \ src/util/zarithNumbers.cmo \ src/util/numbers.cmo \ src/util/timers.cmo \ src/util/options.cmo \ src/util/gc_debug.cmo \ src/util/loc.cmo \ src/util/hashcons.cmo \ src/util/hstring.cmo \ src/structures/exception.cmo \ src/structures/symbols.cmo \ src/structures/ty.cmo \ src/structures/parsed.cmo \ src/structures/typed.cmo \ src/structures/term.cmo \ src/structures/literal.cmo \ src/structures/formula.cmo \ src/structures/explanation.cmo \ src/structures/errors.cmo \ src/util/profiling_default.cmo \ src/util/profiling.cmo \ src/parsing/why_parser.cmo \ src/parsing/why_lexer.cmo \ src/preprocess/existantial.cmo \ src/preprocess/triggers.cmo \ src/preprocess/why_typing.cmo \ src/preprocess/cnf.cmo \ src/instances/matching.cmo \ src/instances/instances.cmo \ src/theories/polynome.cmo \ src/theories/ac.cmo \ src/theories/uf.cmo \ src/theories/use.cmo \ src/theories/intervals.cmo \ src/theories/inequalities.cmo \ src/theories/intervalCalculus.cmo \ src/theories/arith.cmo \ src/theories/records.cmo \ src/theories/bitv.cmo \ src/theories/arrays.cmo \ src/theories/sum.cmo \ src/theories/combine.cmo \ src/theories/ccx.cmo \ src/theories/theory.cmo \ src/sat/sat_solvers.cmo CMOFRONT = src/main/frontend.cmo MAINCMO = $(CMO) $(CMOFRONT) src/main/main_text.cmo ifeq ($(ENABLEGUI),yes) GUICMO = $(CMO) $(CMOFRONT) \ src/gui/gui_session.cmo \ src/gui/why_annoted.cmo \ src/gui/why_connected.cmo \ src/gui/gui_replay.cmo \ src/main/main_gui.cmo else GUICMO = endif CMX = $(CMO:.cmo=.cmx) CMXFRONT = $(CMOFRONT:.cmo=.cmx) MAINCMX = $(MAINCMO:.cmo=.cmx) GUICMX = $(GUICMO:.cmo=.cmx) byte: $(NAME).byte opt: $(NAME).opt #### LIBRARY #$(LIBNAME).cmo: $(CMO) # $(OCAMLC) $(BFLAGS) -pack -o $(LIBNAME).cmo $^ #$(LIBNAME).cmx: $(CMX) # $(OCAMLOPT) $(INCLUDES) -pack -o $(LIBNAME).cmx $^ #### $(NAME).byte: $(MAINCMO) $(OCAMLC) $(BFLAGS) -o $@ $(BIBBYTE) $^ $(NAME).opt: $(MAINCMX) $(OCAMLOPT) $(OFLAGS) -o $@ $(BIBOPT) $^ #### $(GUINAME).byte: $(GUICMO) $(OCAMLC) $(BFLAGS) -o $(GUINAME).byte $(BIBBYTE) $(BIBGUIBYTE) $^ $(GUINAME).opt: $(GUICMX) $(OCAMLOPT) $(OFLAGS) -o $(GUINAME).opt $(BIBOPT) $(BIBGUIOPT) $^ ifeq ($(ENABLEGUI),yes) gui: $(GUINAME).$(OCAMLBEST) else gui: @echo "gui compilation skipped (lablgtksourceview not detected)" endif .PHONY: gui src/util/config.ml: config.status @echo "let date = \""`LANG=en_US; date`"\"" >> src/util/config.ml @echo "let bindir = \""$(BINDIR)"\"" >> src/util/config.ml @echo "let libdir = \""$(LIBDIR)"\"" >> src/util/config.ml @echo "let pluginsdir = \""$(PLUGINSDIR)"\"" >> src/util/config.ml @echo "let datadir = \""$(DATADIR)"\"" >> src/util/config.ml @echo "let mandir = \""$(MANDIR)"\"" >> src/util/config.ml META: config.status @echo "description = \"API of Alt-Ergo: An automatic theorem prover dedicated to program verification\"" > META @echo "version = \""$(VERSION)"\"" >> META # @echo "archive(byte) = \"altErgo.cmo\"" >> META # @echo "archive(native) = \"altErgo.cmx\"" >> META @echo "requires = \"unix num zarith\"" >> META # installation ############## install-byte: install-man mkdir -p $(BINDIR) cp -f $(NAME).byte $(BINDIR)/$(NAME)$(EXE) install-opt: install-man mkdir -p $(BINDIR) cp -f $(NAME).opt $(BINDIR)/$(NAME)$(EXE) install-man: mkdir -p $(MANDIR)/man1 cp -f doc/*.1 $(MANDIR)/man1 install: install-man mkdir -p $(BINDIR) cp -f $(NAME).$(OCAMLBEST) $(BINDIR)/$(NAME)$(EXE) install-gui: cp -f $(GUINAME).$(OCAMLBEST) $(BINDIR)/$(GUINAME)$(EXE) mkdir -p $(DATADIR)/gtksourceview-2.0/language-specs cp -f doc/gtk-lang/alt-ergo.lang $(DATADIR)/gtksourceview-2.0/language-specs/alt-ergo.lang # install-pack-opt: xpack # mkdir -p $(LIBDIR) # cp -f $(LIBNAME).cmx $(LIBDIR) # cp -f $(LIBNAME).o $(LIBDIR) # install-pack-byte: pack META # mkdir -p $(LIBDIR) # cp -f $(LIBNAME).cmo $(LIBDIR) # cp -f $(LIBNAME).cmi $(LIBDIR) # cp -f META $(LIBDIR) # install-pack:: install-pack-byte # ifeq ($(OCAMLBEST),opt) # install-pack:: install-pack-opt # endif # generic rules ############### .SUFFIXES: .mli .ml .cmi .cmo .cmx .mll .mly .tex .dvi .ps .html .mli.cmi: $(OCAMLC) -c $(BFLAGS) $< .ml.cmo: $(OCAMLC) -c $(BFLAGS) $< .ml.o: $(OCAMLOPT) -c $(OFLAGS) $< .ml.cmx: $(OCAMLOPT) -c $(OFLAGS) $< .mll.ml: $(OCAMLLEX) $< > /dev/null .mly.ml: $(OCAMLYACC) -v $< .mly.mli: $(OCAMLYACC) -v $< # clean ####### clean: @for dd in src/util src/structures src/theories src/instances src/sat src/preprocess src/parsing src/gui src/main non-free/plugins/common non-free/plugins/satML non-free/plugins/common non-free/plugins/common non-free/plugins/profiler non-free/plugins/fm-simplex non-free/plugins/ctrl-alt-ergo; do \ rm -f $$dd/*.cm[ioxtp] $$dd/*.cmti $$dd/*.o $$dd/*~ $$dd/*.annot $$dd/*.owz;\ rm -f $(GENERATED) $$dd/*.output META ; \ rm -f $(NAME).byte $(NAME).opt $(GUINAME).opt $(GUINAME).byte *~; \ done @rm -rf altErgo.cm* altErgo.o *.log archi.dot archi.pdf src/*~ *.cmxs *.cmos ctrl-alt-ergo.* alt-ergo-static* *.cmxs *.cma essentiel essentiel.tar.bz2 alt-ergo-$(VERSION)-$(ARCH) # depend ######## .depend depend: $(GENERATED) $(OCAMLDEP) -slash $(LOCAL_INC) src/util/*.ml* src/structures/*.ml* src/theories/*.ml* src/instances/*.ml* src/sat/*.ml* src/preprocess/*.ml* src/parsing/*.ml* src/gui/*.ml* src/main/*.ml* non-free/plugins/common/*ml* non-free/plugins/satML/*ml* non-free/plugins/fm-simplex/*ml* non-free/plugins/profiler/*ml* > .depend include .depend #### BUILD & INSTALL non-free plugins and tools ifeq ($(OCAMLBEST),opt) cae: ctrl-alt-ergo.opt else cae: ctrl-alt-ergo.byte endif ctrl-alt-ergo.opt: cd non-free/ctrl-alt-ergo && $(OCAMLOPT) $(OFLAGS) -o ../../ctrl-alt-ergo.opt $(BIBOPT) ctrlAltErgo.mli ctrlAltErgo.ml ctrl-alt-ergo.byte: cd non-free/ctrl-alt-ergo && $(OCAMLC) $(BFLAGS) -o ../../ctrl-alt-ergo.byte $(BIBBYTE) ctrlAltErgo.mli ctrlAltErgo.ml install-cae: ctrl-alt-ergo.$(OCAMLBEST) mkdir -p $(BINDIR) cp -f ctrl-alt-ergo.$(OCAMLBEST) $(BINDIR)/ctrl-alt-ergo$(EXE) SATML-CMO = non-free/plugins/common/vec.cmo \ non-free/plugins/satML/satml.cmo \ non-free/plugins/satML/satml_frontend.cmo SATML-CMX = $(SATML-CMO:.cmo=.cmx) satML-plugin.cmxs: $(CMX) $(SATML-CMX) $(if $(QUIET),@echo 'Library $@' &&) $(OCAMLOPT) $(INCLUDES) -shared -o $@ $(SATML-CMX) satML-plugin.cma: $(CMO) $(SATML-CMO) $(if $(QUIET),@echo 'Library $@' &&) $(OCAMLC) $(INCLUDES) -a -o $@ $(SATML-CMO) ifeq ($(OCAMLBEST),opt) satML: satML-plugin.cmxs else satML: satML-plugin.cma endif install-satML: satML ifeq ($(OCAMLBEST),opt) mkdir -p $(PLUGINSDIR) cp -f satML-plugin.cmxs $(PLUGINSDIR) else mkdir -p $(PLUGINSDIR) cp -f satML-plugin.cma $(PLUGINSDIR) endif FM-SIMPLEX-CMO = non-free/plugins/common/vec.cmo \ non-free/plugins/fm-simplex/simplex_cache.cmo \ non-free/plugins/fm-simplex/simplex.cmo \ non-free/plugins/fm-simplex/fmSimplexIneqs.cmo FM-SIMPLEX-CMX = $(FM-SIMPLEX-CMO:.cmo=.cmx) fm-simplex-plugin.cmxs: $(CMX) $(FM-SIMPLEX-CMX) $(if $(QUIET),@echo 'Library $@' &&) $(OCAMLOPT) $(INCLUDES) -shared -o $@ $(FM-SIMPLEX-CMX) fm-simplex-plugin.cma: $(CMO) $(FM-SIMPLEX-CMO) $(if $(QUIET),@echo 'Library $@' &&) $(OCAMLC) $(INCLUDES) -a -o $@ $(FM-SIMPLEX-CMO) ifeq ($(OCAMLBEST),opt) fm-simplex: fm-simplex-plugin.cmxs else fm-simplex: fm-simplex-plugin.cma endif install-fm-simplex: fm-simplex ifeq ($(OCAMLBEST),opt) mkdir -p $(PLUGINSDIR) cp -f fm-simplex-plugin.cmxs $(PLUGINSDIR) else mkdir -p $(PLUGINSDIR) cp -f fm-simplex-plugin.cma $(PLUGINSDIR) endif profiler-plugin.cmxs: $(CMX) non-free/plugins/profiler/profiler.cmx $(if $(QUIET),@echo 'Library $@' &&) $(OCAMLOPT) $(INCLUDES) -shared -o $@ non-free/plugins/profiler/profiler.cmx profiler-plugin.cma: $(CMO) non-free/plugins/profiler/profiler.cmo $(if $(QUIET),@echo 'Library $@' &&) $(OCAMLC) $(INCLUDES) -a -o $@ non-free/plugins/profiler/profiler.cmo ifeq ($(OCAMLBEST),opt) profiler: profiler-plugin.cmxs else profiler: profiler-plugin.cma endif install-profiler: profiler ifeq ($(OCAMLBEST),opt) mkdir -p $(PLUGINSDIR) cp -f profiler-plugin.cmxs $(PLUGINSDIR) else mkdir -p $(PLUGINSDIR) cp -f profiler-plugin.cma $(PLUGINSDIR) endif show-dest-dirs: @echo BINDIR = $(BINDIR) @echo LIBDIR = $(LIBDIR) @echo PLUGINSDIR = $(PLUGINSDIR) @echo DATADIR = $(DATADIR) @echo MANDIR = $(MANDIR) # Makefile.configurable is rebuilt whenever Makefile.configurable.in # or configure.in is modified ###################################################################### configure: configure.in autoconf ./configure Makefile.configurable: Makefile.configurable.in configure.in ./config.status config.status: configure ./config.status --recheck # stripped-arch-binary stripped-arch-binary: $(OPT) cp $(OPT) alt-ergo-$(VERSION)-$(ARCH) strip alt-ergo-$(VERSION)-$(ARCH) opam-deps: opam install zarith camlzip conf-gtksourceview ocplib-simplex alt-ergo-1.30/doc/0000755000175000001440000000000013014515065012260 5ustar rtusersalt-ergo-1.30/doc/gtk-lang/0000755000175000001440000000000013014515065013764 5ustar rtusersalt-ergo-1.30/doc/gtk-lang/alt-ergo.lang0000644000175000001440000001032513014515065016342 0ustar rtusers text/x-alt-ergo (* *)