@ \ + @{

@{Metrics@}@}@ \ + @{
Synthetic results@}@
@ \ + @{Defined function(s)@} (%d):
@ \ + @[ %a@]@
@
@ \ + @{Undefined function(s)@} (%d):@
@ \ + @[ %a@]@
@
@ \ + @{Potential entry point(s)@} (%d):@
@ \ + @[ %a@]@
@
@ \ + @}@]" + (VInfoMap.map_cardinal cil_visitor#fundef_calls) + (Metrics_base.pretty_set VInfoMap.iter) cil_visitor#fundef_calls + (VInfoMap.map_cardinal cil_visitor#fundecl_calls) + (Metrics_base.pretty_set VInfoMap.iter) cil_visitor#fundecl_calls + (Metrics_base.number_entry_points VInfoMap.fold + cil_visitor#fundef_calls) + (Metrics_base.pretty_entry_points VInfoMap.iter) + cil_visitor#fundef_calls + in + let pr_detailed_results fmt cil_visitor = + Format.fprintf fmt "@[\ + @{
\ + @[@ \ + @{
Detailed results@}@ \ + @[%a@ @]\ + @]@}" + (fun fmt cil_visitor -> cil_visitor#print_stats fmt) cil_visitor + in + Format.fprintf fmt "@[\ + @ \ + @{@ \ + @{@ \ + @{%s@}@ \ + <meta content=\"text/html; charset=iso-8859-1\" \ + http-equiv=\"Content-Type\"/>@ \ + @{<style type=\"text/css\">%s@}@ \ + @}@ \ + @{<body>\ + @[<v 2>@ \ + %a@ \ + %a@ \ + %a@ \ + @]@}@}@]@?" + "Metrics" + Css_html.css + pr_prelude cil_visitor + pr_stats cil_visitor + pr_detailed_results cil_visitor; +;; + +let metrics_to_result (cil_visitor : slocVisitor) = + let metrics = cil_visitor#get_metrics in + { call_statements = metrics.ccalls; + goto_statements = metrics.cgotos; + assign_statements = metrics.cassigns; + if_statements = metrics.cifs; + mem_access = metrics.cptrs; + loop_statements = metrics.cloops; + function_definitions = metrics.cfuncs; + sloc = metrics.cslocs; + functions_without_source = + VInfoMap.to_varinfo_map cil_visitor#fundecl_calls; + functions_with_source = + VInfoMap.to_varinfo_map cil_visitor#fundef_calls; + cyclos = Metrics_base.cyclo metrics + }; +;; + +let compute_on_cilast () = + let file = Ast.get () in + (* Do as before ) + let cil_visitor = new slocVisitor in + Visitor.visitFramacFileSameGlobals + (cil_visitor:>Visitor.frama_c_visitor) file; + if Metrics_parameters.ByFunction.get () then + Metrics.result "@[<v 0>Cil AST@ %t@]" cil_visitor#pp_detailed_text_metrics; + let r = metrics_to_result cil_visitor in + ( Print the result to file if required ) + let out_fname = OutputFile.get () in + begin + if out_fname <> "" then + try + let oc = open_out_bin out_fname in + let fmt = Format.formatter_of_out_channel oc in + (match Metrics_base.get_file_type out_fname with + | Html -> dump_html fmt cil_visitor + | Text -> + Format.fprintf fmt "@[<v 0>%t@ %a@]" + cil_visitor#pp_detailed_text_metrics + Metrics_base.pretty r + ); + close_out oc; + with Sys_error _ -> + Metrics.failure "Cannot open file %s.@." out_fname + end; + r + +;; + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/metrics/metrics_cilast.mli frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_cilast.mli --- frama-c-20110201+carbon+dfsg/src/metrics/metrics_cilast.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_cilast.mli 2011-10-10 08:38:28.000000000 +0000 @@ -0,0 +1,54 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Visitor to compute various syntactic metrics. + In particular, it fetches all necessary informations to compute + cyclomatic complexity . +) +class type sloc_visitor = object + inherit Visitor.generic_frama_c_visitor + + ( Get the number of times a function has been called if it has been + defined (fundef) or not (fundecl). + ) + method fundecl_calls: int Metrics_base.VInfoMap.t + method fundef_calls: int Metrics_base.VInfoMap.t + + ( Get the computed metris ) + method get_metrics: Metrics_base.my_metrics + + ( Print the metrics of a file [string] to a formatter + Yields a fatal error if the file does not exist (or has no metrics). + *) + method pp_file_metrics: Format.formatter -> string -> unit + + method pp_detailed_text_metrics: Format.formatter -> unit + (** Print results of all file and functions to the given formatter as text *) + + method print_stats: Format.formatter -> unit +(** Print computed metrics to a formatter *) +end + +class slocVisitor: sloc_visitor + +(** Compute metrics on whole CIL AST *) +val compute_on_cilast: unit -> Db.Metrics.t;; diff -Nru frama-c-20110201+carbon+dfsg/src/metrics/metrics_coverage.ml frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_coverage.ml --- frama-c-20110201+carbon+dfsg/src/metrics/metrics_coverage.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_coverage.ml 2011-10-10 08:38:28.000000000 +0000 @@ -0,0 +1,322 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types +open Cil_datatype + + +class coverageAuxVisitor prj = object(self) + inherit Visitor.generic_frama_c_visitor prj (Cil.inplace_visit ()) + + (* Visit the body and the spec of a function ) + method private visit_function vi = + if Metrics_base.consider_function vi then + let kf = Globals.Functions.get vi in + let self = (self :> Visitor.frama_c_visitor) in + ( Visit the spec. There might be references to function pointers in + the assigns ) + let spec = Kernel_function.get_spec ~populate:false kf in + ignore (Visitor.visitFramacFunspec self spec); + (try + ( Visit the body if we have one ) + let fundec = Kernel_function.get_definition kf in + ignore (Visitor.visitFramacFunction self fundec); + with Kernel_function.No_Definition -> ()) + + ( Visit the initializer of the given var, if it exists, and returns it ) + method private visit_non_function_var vi = + try + ( Visit the initializer if there is one ) + let init = Globals.Vars.find vi in + match init with + | { init = None } -> None + | { init = Some init } -> + ignore (Visitor.visitFramacInit (self:>Visitor.frama_c_visitor) + vi NoOffset init); + Some init + with Not_found -> ( not a global ) None + +end + +( Reachability metrics: from a given compute a conservative estimation + of the functions that can be transitively called ) +class callableFunctionsVisitor prj = object(self) + inherit coverageAuxVisitor prj as super + + ( Functions reachable syntactically ) + val mutable callable = Varinfo.Set.empty + + ( All globals initializers visited ) + val mutable initializers = [] + method initializers = initializers + + ( All varinfos visited so far. Used to avoid looping ) + val visited = Varinfo.Hashtbl.create 17 + ( Varinfos remaining to visit ) + val todo = Stack.create () + + method already_seen vi = + Varinfo.Hashtbl.mem visited vi + + ( Each time we see a variable, mark it as to be visited. If it is a function, + consider it is called ) + method vvrbl vi = + if not (self#already_seen vi) then begin + if Cil.isFunctionType vi.vtype then + callable <- Varinfo.Set.add vi callable; + Stack.push vi todo; + end; + Cil.SkipChildren ( no children anyway ) + + method visit_non_function_var vi = + let r = super#visit_non_function_var vi in + (match r with + | None -> () + | Some init -> initializers <- (vi, init) :: initializers + ); + r + + method compute vi = + ( Initialisation ) + Stack.clear todo; + Stack.push vi todo; + Varinfo.Hashtbl.clear visited; + callable <- Varinfo.Set.singleton vi; + ( Reach fixpoint ) + while not (Stack.is_empty todo) do + let vi = Stack.pop todo in + if not (self#already_seen vi) then + begin + Metrics_parameters.Metrics.debug "Coverage: visiting %s" vi.vname; + Varinfo.Hashtbl.add visited vi (); + if Cil.isFunctionType vi.vtype + then self#visit_function vi + else ignore (self#visit_non_function_var vi) + end; + done; + callable + +end + +class deadCallsVisitor fmt ~syntactic ~semantic initializers prj = + let unseen = Varinfo.Set.diff syntactic semantic in +object(self) + inherit coverageAuxVisitor prj + + val mutable current_initializer = None + + ( When an unseen function is reachable by the body of a function reached, + or inside an initializer, display the information ) + method private reached_vi vi = + if Metrics_base.consider_function vi && Varinfo.Set.mem vi unseen then + match self#current_kf with + | None -> + (match current_initializer with + | None -> assert false + | Some vinit -> + Format.fprintf fmt + "@[<h>Initializer of %s references %s (at %a)@]@ " + vinit.vname vi.vname Location.pretty vi.vdecl + ) + | Some f -> + if Varinfo.Set.mem (Kernel_function.get_vi f) semantic then + let mess = + match self#current_stmt with + | Some {skind = Instr (Call (_, {enode = Lval (Var v, _)}, _, _))} + when Varinfo.equal v vi -> "calls" + | _ -> "references" + in + Format.fprintf fmt + "@[<h>Function %a %s %s (at %a)@]@ " + Kernel_function.pretty f mess vi.vname + Location.pretty (Cil.CurrentLoc.get ()) + + method vvrbl vi = + if Cil.isFunctionType vi.vtype then self#reached_vi vi; + Cil.SkipChildren ( no children anyway ) + + + method compute_and_print = + if not (Varinfo.Set.is_empty unseen) || initializers <> [] then begin + Format.fprintf fmt "@[<v>References to non analyzed functions@ \ + ------------------------------------@ "; + Varinfo.Set.iter self#visit_function semantic; + List.iter (fun (vinit, init) -> + current_initializer <- Some vinit; + ignore (Visitor.visitFramacInit + (self:>Visitor.frama_c_visitor) + vinit NoOffset init); + current_initializer <- None; + ) initializers; + Format.fprintf fmt "@]" + end + +end + +class coverageByFun prj = object + inherit Visitor.generic_frama_c_visitor prj (Cil.inplace_visit ()) + + val mutable total = 0 + val mutable value = 0 + + method vstmt s = + total <- total + 1; + if Db.Value.is_reachable_stmt s then value <- value + 1; + Cil.DoChildren + + method result = (total, value) +end + +let compute_coverage_by_fun semantic = + let one_fun vi acc = + try + let kf = Globals.Functions.get vi in + let dec = Kernel_function.get_definition kf in + let vis = new coverageByFun (Project.current ()) in + ignore (Visitor.visitFramacFunction (vis :> Visitor.frama_c_visitor) dec); + let (total, value) = vis#result in + let percent = (float_of_int value) /. (float_of_int total) . 100. in + (kf, total, value, percent) :: acc + with Kernel_function.No_Definition -> acc + in + let res = Varinfo.Set.fold one_fun semantic [] in + List.sort (fun (_, _, _, p1) (_, _, _, p2) -> compare p2 p1) res + + +let pp_unreached_calls fmt ~syntactic ~semantic initializers = + let v = new deadCallsVisitor fmt ~syntactic ~semantic initializers + (Project.current ()) in + v#compute_and_print + +let compute_syntactic kf = + let vis = new callableFunctionsVisitor (Project.current ()) in + let res = vis#compute (Kernel_function.get_vi kf) in + res, vis#initializers + +let compute_semantic () = + assert (Db.Value.is_computed ()); + let res = ref Varinfo.Set.empty in + (* Just iter on all the functions and consult the appropriate table ) + Globals.Functions.iter + (fun kf -> + if !Db.Value.is_called kf then + res := Varinfo.Set.add (Kernel_function.get_vi kf) !res + ); + !res + + +let pp_fun_set_by_file fmt set = + let add_binding map filename fvinfo = + let set = + try + let x = Datatype.String.Map.find filename map in + Varinfo.Set.add fvinfo x + with Not_found -> Varinfo.Set.add fvinfo Varinfo.Set.empty + in Datatype.String.Map.add filename set map + in + let map = + Varinfo.Set.fold + (fun fvinfo acc -> + if Metrics_base.consider_function fvinfo then + let fname = Metrics_base.file_of_vinfodef fvinfo in + add_binding acc fname fvinfo + else acc + ) set Datatype.String.Map.empty + in + Format.fprintf fmt "@[<v 0>"; + Datatype.String.Map.iter + (fun fname fvinfoset -> + Format.fprintf fmt "@[<hov 2><%s>:@ %a@]@ " fname + (fun fmt vinfoset -> + Varinfo.Set.iter + (fun vinfo -> + Format.fprintf fmt "%a;@ " !Ast_printer.d_var vinfo) + vinfoset) + fvinfoset + ) map; + Format.fprintf fmt "@]" +;; + +let pp_value_coverage () = + assert (Db.Value.is_computed ()); + let semantic = compute_semantic () in + let main = fst (Globals.entry_point ()) in + let syntactic, initializers = compute_syntactic main in + let unseen = Varinfo.Set.diff syntactic semantic in + let unseen_num = Varinfo.Set.cardinal unseen in + let nsyn = Varinfo.Set.cardinal syntactic + and nsem = Varinfo.Set.cardinal semantic in + let percent = (float_of_int nsem) /. (float_of_int nsyn) . 100.0 in + (fun fmt -> + Format.fprintf fmt "@[<v 0>\ + Value coverage statistics@ \ + -------------------------@ \ + Syntactically reachable functions = %d@ \ + Semantically reached functions = %d@ \ + Coverage estimation = %.1f%% @ " + nsyn nsem percent; + if unseen_num > 0 then + Format.fprintf fmt "@ @[<v 2>Unseen functions (%d) =@ %a@]" + unseen_num pp_fun_set_by_file unseen; + Format.fprintf fmt "@]" + ), + (fun fmt -> + pp_unreached_calls fmt ~syntactic ~semantic initializers) +;; + +let pp_reached_from_function fmt kf = + let syntactic, _ = compute_syntactic kf in + let title = Pretty_utils.sfprintf "%a: %d" + Kernel_function.pretty kf (Varinfo.Set.cardinal syntactic) + in + Format.fprintf fmt "@[<v 0>\ + Functions syntactically reachable from %s@ \ + ---------------------------------------%s@ \ + %a@]" title (String.make (String.length title) '-') + pp_fun_set_by_file syntactic + +let pp_stmts_reached_by_function fmt = + let semantic = compute_semantic () in + let l = compute_coverage_by_fun semantic in + let sum_total, sum_value = List.fold_left + (fun (at, av) (_, t, v, _) -> at+t, av+v) (0, 0) l in + let percent = 100. . (float_of_int sum_value) /. (float_of_int sum_total) in + Format.fprintf fmt "@[<v 0>\ + Statements analyzed by Value@ \ + ----------------------------@ \ + %d stmts in analyzed functions, %d stmts analyzed (%.1f%%)@ " + sum_total sum_value percent; + List.iter (fun (kf, total, _, percent) -> + Format.fprintf fmt "%a: %.1f%% (%d stmts)@ " + Kernel_function.pretty kf percent total + ) l; + Format.fprintf fmt "@]" + + +( Reexport a simpler function ) +let compute_syntactic kf = fst (compute_syntactic kf) + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/metrics/metrics_coverage.mli frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_coverage.mli --- frama-c-20110201+carbon+dfsg/src/metrics/metrics_coverage.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_coverage.mli 2011-10-10 08:38:28.000000000 +0000 @@ -0,0 +1,44 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +val compute_syntactic: Kernel_function.t -> Cil_datatype.Varinfo.Set.t +( List of functions that can be syntactically reached from the function *) + +val compute_semantic: unit -> Cil_datatype.Varinfo.Set.t +(** Functions analyzed by the value analysis *) + +val pp_reached_from_function: Format.formatter -> Kernel_function.t -> unit +(** Pretty-print the functions that can be syntactically reached from the + parameter ) + +val pp_value_coverage: + unit -> (Format.formatter -> unit) (Format.formatter -> unit) +(** Return two fonctions that pretty-print the coverage reached by the value + analysis wrt. the functions syntactically reachable from main ) + +val pp_stmts_reached_by_function: Format.formatter -> unit + +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/metrics/metrics_parameters.ml frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_parameters.ml --- frama-c-20110201+carbon+dfsg/src/metrics/metrics_parameters.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_parameters.ml 2011-10-10 08:38:28.000000000 +0000 @@ -20,34 +20,73 @@ ( *) (**************************************************************************) -include Plugin.Register +module Metrics = Plugin.Register (struct let name = "metrics" let shortname = "metrics" let help = "syntactic metrics" end) -module Print = - False +let plugin_name = "Metrics";; + +module Enabled = + Metrics.WithOutput (struct - let option_name = "-metrics" - let help = " print some metrics on stdout" - let kind = `Tuning + let option_name = "-metrics" + let help = "activate metrics computation" + let output_by_default = true end) -module Dump = - EmptyString +module ByFunction = + Metrics.False (struct - let option_name = "-metrics-dump" - let arg_name = "" - let help = "print some metrics into the specified file" - let kind = `Tuning + let option_name = "-metrics-by-function" + let help = "also compute metrics on a per-function basis" + let output_by_default = true end) -let is_on () = Print.get () || not (Dump.is_default ()) +module OutputFile = + Metrics.EmptyString + (struct + let option_name = "-metrics-output" + let arg_name = "filename" + let help = "print some metrics into the specified file; \ + the output format is recognized through the extension." + end) + +module ValueCoverage = + Metrics.WithOutput ( + struct + let option_name = "-metrics-value-cover" + let help = "estimate value analysis coverage w.r.t. \ + to reachable syntactic definitions" + let output_by_default = true + end) + +module AST_type = + Metrics.String + (struct + let option_name = "-metrics-ast" + let arg_name = "[cabs | cil]" + let help = "apply metrics to Cabs or CIL AST." + let default = "cil" + end + ) + +let () = AST_type.set_possible_values ["cil"; "cabs"] + +module SyntacticallyReachable = + Metrics.StringSet + (struct + let option_name = "-metrics-cover" + let arg_name = "f1,..,fn" + let help = "compute an overapproximation of the functions reachable from \ + f1,..,fn." + end + ) (* Local Variables: -compile-command: "LC_ALL=C make -C ../.." +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/metrics/metrics_parameters.mli frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_parameters.mli --- frama-c-20110201+carbon+dfsg/src/metrics/metrics_parameters.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/metrics/metrics_parameters.mli 2011-10-10 08:38:28.000000000 +0000 @@ -20,21 +20,34 @@ ( *) (************************************************************************) -open Plugin +module Metrics: Plugin.S -( Pretty print metrics on stdout *) -module Print: BOOL +module Enabled: Plugin.WithOutput +(** Activate metrics *) -(** Pretty print metrics on the given file *) -module Dump: STRING +module ByFunction: Plugin.Bool +(** Activate metrics by function *) -(** Have metrics to be computed? *) -val is_on: unit -> bool +module ValueCoverage: Plugin.WithOutput +(** Give an estimation about value analysis code penetration. + Only works on CIL AST. *) + +module AST_type: Plugin.String +(** Set the ASTs on which the metrics should be computetd *) + +module OutputFile: Plugin.String +(** Pretty print metrics to the given file. + The output format will be recognized through the extension. + Supported extensions are: + "html" or "htm" for HTML + "txt" or "text" for text +*) -include Log.Messages +module SyntacticallyReachable: Plugin.String_set +(** List of functions for which we compute the functions they may call ) ( Local Variables: -compile-command: "LC_ALL=C make -C ../.." +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/metrics/register_gui.ml frama-c-20111001+nitrogen+dfsg/src/metrics/register_gui.ml --- frama-c-20110201+carbon+dfsg/src/metrics/register_gui.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/metrics/register_gui.ml 2011-10-10 08:38:28.000000000 +0000 @@ -20,49 +20,38 @@ ( *) (**************************************************************************) -(* ABP added ) open Cil_types open Visitor open Pretty_source open Kernel_function +open Metrics_base +;; -class cyclo_class (main_ui:Design.main_window_extension_points) = -object(self) +class cyclo_class (main_ui:Design.main_window_extension_points) = object(self) val mutable fct_to_check = (GText "") method get_data = - let checker = (new Register.slocVisitor) in - checker#set_standalone false; - Metrics_parameters.debug "beginning of cyclo check"; - ignore (visitFramacGlobal - (checker :> frama_c_visitor) - fct_to_check); - checker#sloc, - checker#ifs, - checker#assigns, - checker#loops, - checker#calls, - checker#gotos, - checker#mem_access, - (checker#ifs + checker#loops) - checker#exits + 2 + let checker = (new Metrics_cilast.slocVisitor) in + Metrics_parameters.Metrics.debug ~level:2 "Beginning of cyclo check@."; + ignore (visitFramacGlobal (checker :> frama_c_visitor) fct_to_check); + checker#get_metrics ( 2 becomes "2checker#funcs" in the general case ) method insert_text (buffer: GText.buffer) = let iter = buffer#get_iter `START in - let data = self#get_data in - let (slocs,ifs,assigns,loops,calls, gotos, mems,cyclos) = data in - buffer#insert ~iter (string_of_int slocs); - buffer#insert ~iter (string_of_int ifs); - buffer#insert ~iter (string_of_int assigns); - buffer#insert ~iter (string_of_int loops); - buffer#insert ~iter (string_of_int calls); - buffer#insert ~iter (string_of_int gotos); - buffer#insert ~iter (string_of_int mems); - buffer#insert ~iter (string_of_int cyclos) + let metrics_data = self#get_data in + buffer#insert ~iter (string_of_int metrics_data.cslocs); + buffer#insert ~iter (string_of_int metrics_data.cifs); + buffer#insert ~iter (string_of_int metrics_data.cassigns); + buffer#insert ~iter (string_of_int metrics_data.cloops); + buffer#insert ~iter (string_of_int metrics_data.ccalls); + buffer#insert ~iter (string_of_int metrics_data.cgotos); + buffer#insert ~iter (string_of_int metrics_data.cptrs); + buffer#insert ~iter (string_of_int (cyclo metrics_data)) method do_cyclo (main_ui:Design.main_window_extension_points) = - Metrics_parameters.debug "Cyclo"; + Metrics_parameters.Metrics.debug "Cyclo"; (* create a small results window ) let dialog = GWindow.window ~title:"Measure" @@ -75,22 +64,21 @@ dialog#set_transient_for main_ui#main_window#as_window; let a_vbox = GPack.vbox ~packing:dialog#add () in ignore (dialog#event#connect#delete - ~callback:(fun _ -> dialog#misc#hide (); - true)); - let data = self#get_data in - let (slocs, ifs, assigns, loops, calls, gotos, mems, cyclos) = data in + ~callback:(fun _ -> dialog#misc#hide (); + true)); + let metrics_data = self#get_data in let add_label msg n = let text = msg ^ string_of_int n in ignore (GMisc.label ~text ~packing:a_vbox#add ()) in - add_label "Lines of source code: " slocs; - add_label "# of if statements: " ifs; - add_label "# of assignments: " assigns; - add_label "# of loops: " loops; - add_label "# of function calls: " calls; - add_label "# of gotos: " gotos; - add_label "# of indirect memory accesses: " mems; - add_label "Cyclomatic complexity: " cyclos; + add_label "Lines of source code: " metrics_data.cslocs; + add_label "# of if statements: " metrics_data.cifs; + add_label "# of assignments: " metrics_data.cassigns; + add_label "# of loops: " metrics_data.cloops; + add_label "# of function calls: " metrics_data.ccalls; + add_label "# of gotos: " metrics_data.cgotos; + add_label "# of indirect memory accesses: " metrics_data.cptrs; + add_label "Cyclomatic complexity: " (cyclo metrics_data); let close_button = GButton.button ~stock:`OK ~packing:a_vbox#add () in close_button#set_border_width 10; ignore (close_button#connect#clicked ~callback:dialog#misc#hide); @@ -100,53 +88,60 @@ method display_localizable localizable () = begin match localizable with - | PVDecl (Some kf,_) -> ( Process only the function selected ) - begin - ( Get the global of this function ) - fct_to_check <- (get_global kf); - self#do_cyclo main_ui; - end - | _ -> () + | PVDecl (Some kf,_) -> ( Process only the function selected ) + begin + ( Get the global of this function ) + fct_to_check <- (get_global kf); + self#do_cyclo main_ui; + end + | _ -> () end method cyclo_selector (popup_factory:GMenu.menu GMenu.factory) _main_ui ~button localizable = - Metrics_parameters.debug "cyclo_selector"; + Metrics_parameters.Metrics.debug "cyclo_selector"; if button = 3 then match localizable with - | PVDecl (Some _, _) -> - let callback () = - Metrics_parameters.debug "cyclo_selector - callback"; + | PVDecl (Some _, _) -> + let callback () = + Metrics_parameters.Metrics.debug "cyclo_selector - callback"; self#display_localizable localizable () - in - ignore (popup_factory#add_item "Metrics" ~callback:callback) - | _ -> () + in + ignore (popup_factory#add_item "Metrics" ~callback:callback) + | _ -> () initializer main_ui#register_source_selector self#cyclo_selector - end ( ABP end ) let make_bi_label (parent:GPack.box) l1 = - let container = GPack.hbox ~packing:parent#pack () in - let t = GMisc.label ~text:l1 ~xalign:0.0 - ~packing:(container#pack ~expand:false ~fill:false) - () - in - Gtk_helper.old_gtk_compat t#set_width_chars 7; - let l = GMisc.label ~selectable:true ~xalign:0.0 ~text:"" - ~packing:(container#pack ~expand:true) - () - in - l + let container = GPack.hbox ~packing:parent#pack () in + let t = GMisc.label ~text:l1 ~xalign:0.0 + ~packing:(container#pack ~expand:false ~fill:false) + () + in + Gtk_helper.old_gtk_compat t#set_width_chars 7; + let label = GMisc.label ~selectable:true ~xalign:0.0 ~text:"" + ~packing:(container#pack ~expand:true) + () + in label let make_hbox (parent:GPack.box) = - GPack.hbox ~homogeneous:true ~packing:parent#pack () + GPack.hbox ~homogeneous:true ~packing:parent#pack () + +module LastResult = + State_builder.Option_ref + (DatatypeMetrics) + (struct + let dependencies = [ Ast.self ] + let name = name + let kind = `Internal + end) +;; let make_panel _main_ui = let w = GPack.vbox ~width:120 () in - let update_button = let w = make_hbox w in GButton.button ( ~stock:`REFRESH ) ~label:"Measure" @@ -156,22 +151,22 @@ let box = make_hbox w in ( Sloc ) - let sloc_label = make_bi_label box "sloc:" in + let sloc_label = make_bi_label box "Slocs:" in ( Calls ) - let calls_label = make_bi_label box "calls:" in + let calls_label = make_bi_label box "Calls:" in let box = make_hbox w in ( If ) - let if_label = make_bi_label box "if:" in + let if_label = make_bi_label box "If:" in ( while ) - let loops_label = make_bi_label box "loops:" in + let loops_label = make_bi_label box "Loops:" in let box = make_hbox w in ( Goto ) - let goto_label = make_bi_label box "goto:" in + let goto_label = make_bi_label box "Goto:" in ( assign ) - let assign_label = make_bi_label box "assigns:" in + let assign_label = make_bi_label box "Assigns:" in let box = make_hbox w in ( Mem ) @@ -185,7 +180,7 @@ let proto_label = make_bi_label box "Proto:" in let box = make_hbox w in - ( cyclomatric complexity ) + ( cyclomatic complexity ) let cyclo_label = make_bi_label box "Cyclo:" in let _placeholder2 = make_bi_label box "" in @@ -213,8 +208,8 @@ sloc = sloc; functions_without_source = fws; functions_with_source = fs; - cyclos = cycl; } - = !Db.Metrics.last_result () + cyclos = cycl; } + = LastResult.get () in update_button#misc#set_sensitive false; sloc_label#set_text (string_of_int sloc); @@ -225,9 +220,8 @@ assign_label#set_text (string_of_int assigns); mem_label#set_text (string_of_int mem_access); func_label#set_text - (string_of_int (Cil_datatype.Varinfo.Hashtbl.length fs)); - proto_label#set_text - (string_of_int(Cil_datatype.Varinfo.Hashtbl.length fws)); + (string_of_int (Metrics_base.map_cardinal_varinfomap fs)); + proto_label#set_text (string_of_int(map_cardinal_varinfomap fws)); cyclo_label#set_text (string_of_int cycl) with Not_found -> update_button#misc#set_sensitive true ; @@ -235,7 +229,7 @@ in ignore (update_button#connect#clicked - (fun () -> !Db.Metrics.compute (); fill ())); + (fun () -> LastResult.set (!Db.Metrics.compute ()); fill ())); "Metrics", w#coerce, Some fill let gui (main_ui:Design.main_window_extension_points) = diff -Nru frama-c-20110201+carbon+dfsg/src/metrics/register.ml frama-c-20111001+nitrogen+dfsg/src/metrics/register.ml --- frama-c-20110201+carbon+dfsg/src/metrics/register.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/metrics/register.ml 2011-10-10 08:38:28.000000000 +0000 @@ -20,613 +20,71 @@ ( *) (**************************************************************************) -open Format -open Cil -open Cil_types -open Cil_datatype -open Db.Metrics - -let name = "metrics" - -type int8 = intintintintintintintint - -module LastResult = - State_builder.Option_ref - (Datatype.Make - (struct - include Datatype.Serializable_undefined - type t = Db.Metrics.t - let name = name - let structural_descr = Structural_descr.Abstract - let reprs = - [ { sloc = -1; - call_statements = -1; - goto_statements = -1; - assign_statements = -1; - if_statements = -1; - loop_statements = -1; - mem_access = -1; - functions_without_source = Varinfo.Hashtbl.create 7; - functions_with_source = Varinfo.Hashtbl.create 7; - ( ABP added 2 fields below) - function_definitions = -1; - cyclos = -1 } ] - let mem_project = Datatype.never_any_project - end)) - (struct - let dependencies = [ Ast.self ] - let name = name - let kind = `Internal - end) - -let pretty_set fmt s = - Format.fprintf fmt "@["; - Varinfo.Hashtbl.iter - (fun f n -> - Format.fprintf fmt "%s %s (%d call%s);@ " - f.vname - (if f.vaddrof then "(address taken)" else "") - n (if n > 1 then "s" else "")) - s; - Format.fprintf fmt "@]" - -let number_entry_points fs = - Varinfo.Hashtbl.fold - (fun f n acc -> if n = 0 && not f.vaddrof then succ acc else acc) - fs - 0 - -let pretty_entry_points fmt fs = - let print = - Varinfo.Hashtbl.iter - (fun f n -> - if n = 0 && not f.vaddrof then Format.fprintf fmt "%s;@ " f.vname) - in - Format.fprintf fmt "@["; - print fs; - Format.fprintf fmt "@]" - -let pretty fmt = - let m = LastResult.get () in - Format.fprintf fmt - "@[Defined function (%d):@\n @[%a@]@\nUndefined functions (%d):@\n @[%a@]@\nPotential entry points (%d):@\n @[%a@]@\nSLOC: %d@\nNumber of if statements: %d@\nNumber of assignments: %d@\nNumber of loops: %d@\nNumber of calls: %d@\nNumber of gotos: %d@\nNumber of pointer access: %d@]" - (Varinfo.Hashtbl.length m.functions_with_source) - pretty_set m.functions_with_source - (Varinfo.Hashtbl.length m.functions_without_source) - pretty_set m.functions_without_source - (number_entry_points m.functions_with_source) - pretty_entry_points m.functions_with_source - m.sloc - m.if_statements - m.assign_statements - m.loop_statements - m.call_statements - m.goto_statements - m.mem_access - -let dump () = - let filename = Metrics_parameters.Dump.get () in - try - let cout = open_out_bin filename in - let fmt = Format.formatter_of_out_channel cout in - pretty fmt; - close_out cout - with Sys_error _ as e -> - Metrics_parameters.warning "Cannot open file \"%s\" for dumping metrics: %s" - filename (Printexc.to_string e) - -let null_position : Lexing.position = - { Lexing.pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = 0 } - -let null_location : Cil_types.location = (null_position, null_position) - -let fun_equal (a:global) (b:global) = - match a with - GFun (af,_) -> - begin - match b with - GFun (bf,_) -> (af == bf) - | _ -> false - end - | _ -> false - -let file_of glob = - ( returns the file name to which belongs glob ) - let res = ref "" in - let all_files = Globals.FileIndex.get_files () in - begin - for j = 0 to (List.length all_files)-1 do - let f = (List.nth all_files j) in - let (_,globs) = Globals.FileIndex.find f in - for i = 0 to (List.length globs)-1 do - let elt = ((List.nth globs i) :> global) in - if (fun_equal elt glob) then - res:=f - done - done; - !res - end - -let image_int8 (a:int8) = - let (a1,a2,a3,a4,a5,a6,a7,a8) = a in - "(" ^ (string_of_int a1) ^ "," ^ - (string_of_int a2) ^ "," ^ - (string_of_int a3) ^ "," ^ - (string_of_int a4) ^ "," ^ - (string_of_int a5) ^ "," ^ - (string_of_int a6) ^ "," ^ - (string_of_int a7) ^ "," ^ - (string_of_int a8) ^ ")" - -let plus (a:int8) (b:int8) = - let (a1,a2,a3,a4,a5,a6,a7,a8) = a in - let (b1,b2,b3,b4,b5,b6,b7,b8) = b in - (a1+b1,a2+b2,a3+b3,a4+b4,a5+b5,a6+b6,a7+b7,a8+b8) - -class slocVisitor = object(self) - inherit Visitor.generic_frama_c_visitor - (Project.current ()) (Cil.inplace_visit ()) - val mutable current_file_name:string = "" - val mutable current_function_name:string = "" - val mutable sloc = 0 - val mutable ifs = 0 - val mutable loops = 0 - val mutable calls = 0 - val mutable gotos = 0 - val mutable assigns = 0 - val mutable exits = 0 - val mutable funcs = 0 - ( table of all statistics per module and per function: - stats(file,f) = (#ifs, #assign, #loop, #calls, #gotos, #pointers, #exits, cyclo) - ) - val mutable stats: - (stringstring(intintintintintintintint)) list ref = ref [] - - method stats_of_fic f = - (* get only the stats that are relative to file fic. remove them - from stats and return them ) - let prop element = - let (fic,_,_) = element in - (f=fic) - in - let (good, bad) = (List.partition prop !stats) in - stats <- ref bad; - good - - method complete_stats () = - ( When using this visitor no cyclomatic complexity is calculated - during the traversal of the AST. It has to be calculated AFTER - cisiting the entire global function. We revisit on site every tuple - of stats and calculate the last item. ) - let tout = !stats in - if tout <> [] then - let res = ref [] in - let do_it e = - let (fic,func,(a,b,c,d,e,f,g,h)) = e in - begin - if h <> 0 then - prerr_endline "metrics.complete_stats ERROR"; - res := List.append !res [(fic,func,(a,b,c,d,e,f,g,a+c-g+2))] - end - in List.iter do_it tout; - stats := !res - - method print_stats fmt = - let print_item e = - let _, func, (a,b,c,d,e,f,g,h) = e in - Metrics_parameters.debug - "stats: func: %s@\n\ -val: ifs %d@\n\ - assigns %d@\n\ - loops %d@\n\ - calls %d@\n\ - gotos %d@\n\ - mems %d@\n\ - exits %d@\n\ - cyclo %d" - func a b c d e f g h; - fprintf fmt "<tr>\n"; - fprintf fmt "<td> %s </td>\n" func; - fprintf fmt "<td> %d </td>\n" a; - fprintf fmt "<td> %d </td>\n" b; - fprintf fmt "<td> %d </td>\n" c; - fprintf fmt "<td> %d </td>\n" d; - fprintf fmt "<td> %d </td>\n" e; - fprintf fmt "<td> %d </td>\n" f; - fprintf fmt "<td> %d </td>\n" g; - fprintf fmt "<td> %d </td>\n" h; - fprintf fmt "</tr>\n"; - in - while List.length !stats > 0 do - let first = List.hd !stats in - let (fic,_,_) = first in - let fic_stats = (self#stats_of_fic fic) in - ( print header specific to fic ) - fprintf fmt "<h3> %s </h3>\n" fic; - fprintf fmt " \n"; - fprintf fmt "<table style=\"width: 252px; height: 81px;\" border=\"1\">\n"; - fprintf fmt " <tbody>\n"; - fprintf fmt " <tr>\n"; - fprintf fmt " <th>Function</th>\n"; - fprintf fmt " <th>#If stmts \n"; - fprintf fmt " <th>#Assignments \n"; - fprintf fmt " <th>#Loops \n"; - fprintf fmt " <th>#Calls \n"; - fprintf fmt " <th>#Gotos \n"; - fprintf fmt " <th>#Pointer accesses \n"; - fprintf fmt " <th>#Exits \n"; - fprintf fmt " <th>Cyclomatic value \n"; - fprintf fmt " </th>\n"; - fprintf fmt " </tr>\n"; - List.iter print_item fic_stats; - ( print trailer specific to fic ) - fprintf fmt " </tbody>\n"; - fprintf fmt "</table>\n" - done - - method add_item (a:string) (b:string) (c:int8) l = - ( add a new item to the list stats ) - if (List.length l) = 0 then - [(a,b,c)] - else ( there's at least 1 element ) - let premier = (List.hd l) in - let (x,y,z) = premier in - let reste = (List.tl l) in - if (x,y)=(a,b) then - List.append [(x,y,(plus c z))] reste - else - List.append [premier] (self#add_item a b c reste) - - method add_stat (a,b,c) = - ( add one new item to stats ) - stats := (self#add_item a b c !stats) - - method assigns = assigns - method calls = calls - method gotos = gotos - method loops = loops - method ifs = ifs - method exits = exits - method funcs = funcs - val mutable standalone = true - method set_standalone v = begin standalone <- v end - val mutable mem_access = 0 - method mem_access = mem_access - val functions_no_source = Varinfo.Hashtbl.create 97 - val functions_with_source = Varinfo.Hashtbl.create 97 - method functions_no_source = functions_no_source - method functions_with_source = functions_with_source - method vvdec vi = - if isFunctionType vi.vtype then - if not (Varinfo.Hashtbl.mem functions_with_source vi) then - Varinfo.Hashtbl.replace functions_no_source vi - (try Varinfo.Hashtbl.find functions_no_source vi with Not_found -> 0); - DoChildren - - method vfunc fdec = - current_file_name <- file_of (GFun (fdec, null_location)); - current_function_name <- fdec.svar.vname; - self#add_stat (current_file_name,current_function_name,(0,0,0,0,0,0,0,0)); - funcs <- funcs+1; - let n = - try - let n = Varinfo.Hashtbl.find functions_no_source fdec.svar in - Varinfo.Hashtbl.remove functions_no_source fdec.svar; - n - with Not_found -> - 0 - in - let n = - try Varinfo.Hashtbl.find functions_with_source fdec.svar + n - with Not_found -> n - in - Varinfo.Hashtbl.replace functions_with_source fdec.svar n; - DoChildren - - method vlval (host,_) = - begin - match host with - | Mem _ -> mem_access <- mem_access + 1; - self#add_stat (current_file_name,current_function_name,(0,0,0,0,0,1,0,0)) - | _ -> () - end; - DoChildren - - method sloc = sloc - method vstmt s = - sloc <- sloc + 1 ; - begin match s.skind with - | If _ -> - ifs <- ifs + 1; - self#add_stat (current_file_name,current_function_name,(1,0,0,0,0,0,0,0)) - | Loop _ -> - loops <- loops + 1; - self#add_stat (current_file_name,current_function_name,(0,0,1,0,0,0,0,0)) - | Goto _ -> - gotos <- gotos + 1; - self#add_stat (current_file_name,current_function_name,(0,0,0,0,1,0,0,0)) - | Return _ -> - exits <- exits + 1; - self#add_stat (current_file_name,current_function_name,(0,0,0,0,0,0,1,0)) - | _ -> () - end; - DoChildren - - method find_global_function (v:varinfo) = - ( return a pair (found,spec_or_body) ) - let found:bool ref = ref false in - let spec:bool ref = ref false in - iterGlobals (Ast.get()) ( - function glob -> - match glob with - | GFun (s,_) -> ( function with code ) - if (s.svar==v) then found:=true;spec:=false - | GVarDecl (_,s,_) -> ( function w/o code ) - if (s==v) then found:=true;spec:=true - | _ -> ()); - (!found,!spec) - - method image (glob:global) = - ( extract just the name of the global , for printing purposes ) - match glob with - | GVar (v,_,_) -> v.vname ^ " (GVar) " - | GVarDecl (_,v,_) -> v.vname ^ " (GVarDecl) " - | GFun (fdec, _) -> fdec.svar.vname ^ " (GFun) " - | GType (ty, _) -> ty.tname - | GCompTag (ci, _) | GCompTagDecl (ci, _) -> ci.cname - | GEnumTagDecl (ei,_) | GEnumTag (ei,_) -> ei.ename - | GAsm (_,_) | GPragma _ | GText _ -> "" - | GAnnot (an,_) -> - match an with - Dfun_or_pred (li,_) -> li.l_var_info.lv_name - | Daxiomatic (s,_,_) -> s - | Dtype (lti,_) -> lti.lt_name - | Dlemma (ln, _, _, _, _, _) -> ln - | Dinvariant (toto,_) -> toto.l_var_info.lv_name - | Dtype_annot (ta,_) -> ta.l_var_info.lv_name - - method images (globs:global list) = - ( extract just the names of the globals, for printing purposes ) - let les_images = List.map self#image globs in - String.concat "," les_images - - method print_all = - prerr_endline (" print_all"); - let all_files = Globals.FileIndex.get_files () in - let print_one fic = - let (_,glob) = Globals.FileIndex.find fic in - prerr_endline ("* " ^ fic ^ " : " ^ (self#images glob)) - in - List.iter print_one all_files - - method vinst i = - begin match i with - | Call(_, e, _, _) -> - calls <- calls + 1; - self#add_stat (current_file_name,current_function_name,(0,0,0,1,0,0,0,0)); - (match e.enode with - | Lval(Var v, NoOffset) -> - let next tbl = - Varinfo.Hashtbl.replace tbl v (succ (Varinfo.Hashtbl.find tbl v)) - in - begin - try next functions_with_source; - with Not_found -> - try next functions_no_source; - with Not_found -> - (* if this iterator is called on a specific global - function only, it might not find the target of this call - so we check if this function is w/ or w/o source and - add 1 to the number of calls accordingly. - ) - ( self#print_all; ) - if not standalone then - let (ya,codeless) = self#find_global_function v in - if ya then - begin - if codeless then - Varinfo.Hashtbl.replace functions_with_source v 0 - else - Varinfo.Hashtbl.replace functions_no_source v 0 - end - else - Metrics_parameters.fatal "Got no source for %s" v.vname - else - Metrics_parameters.fatal "Got no source for %s" v.vname - end - | _ -> ()); - DoChildren - | Set _ -> - assigns <- succ assigns; - self#add_stat (current_file_name,current_function_name,(0,1,0,0,0,0,0,0)); - DoChildren - | _ -> DoChildren - end - -end - -( This may be used to generate code associated to prototypes. - -let find_lvals_to_assign vi = - let rec rec_find_lvals lval = - let typ = typeOfLval lval in - if isArithmeticType typ then [lval] - else if isPointerType typ then - rec_find_lvals (mkMem ~addr:(Lval lval) ~off:NoOffset) - else assert false - in - if isPointerType vi.vtype then - (* find the lvals of basic types ) - rec_find_lvals (mkMem ~addr:(Lval (Var vi,NoOffset)) ~off:NoOffset) - else [] - -let make_body_from_prototype vi = - vi.vstorage <- NoStorage; - let new_fundec = - { svar = vi; - smaxid = 0; - slocals = []; - sformals = []; - sbody = mkBlock []; - smaxstmtid = None; - sallstmts = []; - sspec = {requires = None; - assigns = None; - ensures = None; - decreases = None} - } - in - ( formal might have no name, let's fix the type to generate a name:) - vi.vtype <- begin match vi.vtype with - | TFun (typ, None, b, attr) -> vi.vtype - | TFun (typ, Some args, b, attr) -> - let counter = ref 0 in - let named_args = - List.map - (fun (n,t,a) -> - (if n= "" then - begin incr counter; - "Frama_C_formals_"^(string_of_int !counter) - end - else n), - t,a) - args - in - TFun (typ, Some named_args, b, attr) - | _ -> assert false - end; - setFunctionTypeMakeFormals new_fundec vi.vtype; - let fresh_global = GFun (new_fundec,vi.vdecl) in - let fresh_volatile = - makeLocalVar - new_fundec - "Frama_C_entropy_source" - (typeAddAttributes [Attr ("volatile",[])] (TInt(IULongLong, [])) ) - in - let volatile_lval = Lval(Var fresh_volatile,NoOffset) in - List.iter (fun formal -> - let lvals_to_assign = find_lvals_to_assign formal in - let stmts = - List.map - (fun lval_to_assign -> - mkStmtOneInstr - (Set (lval_to_assign, - volatile_lval, - vi.vdecl))) - lvals_to_assign - in - let conditional - new_fundec.sbody.bstmts <- new_fundec.sbody.bstmts@stmts; - ) - new_fundec.sformals; - - Format.printf "Made: <@\n %a@\n>@." d_global fresh_global; - new_fundec - -class turn_prototype_into_body protos_vi turn_into = object(self) - inherit nopCilVisitor - - method vglob glob = - match glob with - | GVarDecl (fspec, vi, loc) when Cil_datatype.Varinfo.Set.mem vi protos_vi -> - assert (isFunctionType vi.vtype); - ChangeTo [GFun(make_body_from_prototype vi,loc)] +open Metrics_base +open Metrics_parameters - | _ -> SkipChildren +let () = Enabled.set_output_dependencies + [Ast.self; AST_type.self; OutputFile.self; SyntacticallyReachable.self] -end +let syntactic () = + begin + match AST_type.get () with + | "cil" -> + let r = !Db.Metrics.compute () in + Metrics.result + "@[<v 0>Syntactic metrics@ \ + -----------------@ %a@]" + !Db.Metrics.pretty r -) + (* Cabs metrics are experimental. unregistered, unjournalized ) + | "cabs" -> Metrics_cabs.compute_on_cabs () + + | _ -> assert false ( the possible values are checked by the kernel) + end; -let compute () = - let file = Ast.get () in - let v = new slocVisitor in - v#set_standalone true; ( measure the entire code ) - visitCilFileSameGlobals (v:>cilVisitor) file; - v#complete_stats (); - LastResult.set - { call_statements = v#calls; - goto_statements = v#gotos; - assign_statements = v#assigns; - if_statements = v#ifs; - mem_access = v#mem_access; - loop_statements = v#loops; - function_definitions = v#funcs; - sloc = v#sloc; - functions_without_source = v#functions_no_source; - functions_with_source = v#functions_with_source; - cyclos = (v#ifs +v#loops) - v#exits +2v#funcs - }; - (* print results on HTML file ) - let cout = open_out "metrics.html" in - let fmt = formatter_of_out_channel cout in - ( header ) - fprintf fmt "<!DOCTYPE HTML PUBLIC >\n"; - fprintf fmt "<html>\n"; - fprintf fmt "<head>\n"; - fprintf fmt "</head>\n"; - fprintf fmt "<body>\n"; - fprintf fmt "<div style=\"text-align: left;\">\n"; - fprintf fmt "<h1>Metrics</h1>\n"; - fprintf fmt "<h2>Synthetic results</h2>\n"; - fprintf fmt " \n"; - ( ) ( global stats ) - fprintf fmt "Defined function (%d): \n" - (Varinfo.Hashtbl.length v#functions_with_source); - ( ) - fprintf fmt "@[ %a@]@ \n" pretty_set v#functions_with_source; - fprintf fmt " \n"; - fprintf fmt "Undefined functions (%d): \n" (Varinfo.Hashtbl.length v#functions_no_source); - ( ) - fprintf fmt "@[ %a@]@ \n" pretty_set v#functions_no_source; - fprintf fmt " \n"; - ( ) - fprintf fmt "Potential entry points (%d): \n" (number_entry_points v#functions_with_source); - ( ) - fprintf fmt "@[ %a@]@ \n" pretty_entry_points v#functions_with_source; - fprintf fmt " \n"; - ( TBD other gloabl stats ) - fprintf fmt "SLOC: (%d) \n" v#sloc; - fprintf fmt "Number of if statements: (%d) \n" v#ifs; - fprintf fmt "Number of assignments: (%d) \n" v#assigns; - fprintf fmt "Number of loops: (%d) \n" v#loops; - fprintf fmt "Number of calls: (%d) \n" v#calls; - fprintf fmt "Number of gotos: (%d) \n" v#gotos; - fprintf fmt "Number of pointer access: (%d) \n" v#mem_access; - fprintf fmt " \n"; - fprintf fmt "<h2>Detailed results</h2>\n"; - fprintf fmt " \n"; - ( detailed stats ) - v#print_stats fmt; - close_out cout; - Metrics_parameters.feedback "Metrics printed to file metrics.html" + SyntacticallyReachable.iter + (fun s -> + try let kf = Globals.Functions.find_by_name s in + Metrics.result "%a" Metrics_coverage.pp_reached_from_function kf + with Not_found -> Metrics.error "Unknown function %s" s + ); +;; + + +let () = ValueCoverage.set_output_dependencies [Db.Value.self] + +let value () = + !Db.Value.compute (); + if Db.Value.is_computed () then begin + let f1, f2 = Metrics_coverage.pp_value_coverage () in + Metrics.result "%t" f1; + Metrics.result "%t" f2; + Metrics.result "%t" Metrics_coverage.pp_stmts_reached_by_function; + end +;; let main () = - if Metrics_parameters.is_on () then begin - !Db.Metrics.compute (); - if Metrics_parameters.Print.get () then - Metrics_parameters.result "Syntactic metrics@\n %t" !Db.Metrics.pretty; - if Metrics_parameters.Dump.get () <> "" then - !Db.Metrics.dump () - end + if Enabled.get () then Enabled.output syntactic; + if ValueCoverage.get () then ValueCoverage.output value; +;; + +( Main entry points ) let () = Db.Main.extend main +( Register some functions in Frama-C's DB ) let () = - Db.register + Db.register (Db.Journalize - ("Metrics.compute", Datatype.func Datatype.unit Datatype.unit)) - Db.Metrics.compute compute; + ("Metrics.compute", Datatype.func Datatype.unit DatatypeMetrics.ty)) + Db.Metrics.compute Metrics_cilast.compute_on_cilast; + Db.register (Db.Journalize - ("Metrics.pretty", Datatype.func Datatype.formatter Datatype.unit)) + ("Metrics.pretty", Datatype.func Datatype.formatter + (Datatype.func DatatypeMetrics.ty Datatype.unit))) Db.Metrics.pretty pretty; - Db.register - (Db.Journalize ("Metrics.dump", Datatype.func Datatype.unit Datatype.unit)) - Db.Metrics.dump dump; - Db.register Db.Journalization_not_required - Db.Metrics.last_result LastResult.get - +;; ( Local Variables: compile-command: "make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/misc/bit_utils.ml frama-c-20111001+nitrogen+dfsg/src/misc/bit_utils.ml --- frama-c-20110201+carbon+dfsg/src/misc/bit_utils.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/bit_utils.ml 2011-10-10 08:38:28.000000000 +0000 @@ -41,24 +41,21 @@ (Int.of_int (8+sizeofpointer ()))) -let max_bit_address () = Int.pred (Int.power_two (sizeofpointer ()+7)) let max_bit_size () = Int.power_two (7+(sizeofpointer ())) +let max_bit_address () = Int.pred (max_bit_size()) let warn_if_zero ty r = if r = 0 then - (ignore - (Cil.error - "size of '%a' is zero. Check target code or Frama-C -machdep option." - !Ast_printer.d_type ty); - exit 1;); + Kernel.abort + "size of '%a' is zero. Check target code or Frama-C -machdep option." + !Ast_printer.d_type ty; r (** [sizeof ty] is the size of [ty] in bits. This function may return [Int_Base.top]. ) let sizeof ty = (match ty with - | TVoid _ -> - CilE.warn_once "using size of 'void'" + | TVoid _ -> Kernel.warning ~current:true ~once:true "using size of 'void'" | _ -> ()) ; try Int_Base.inject (Int.of_int (bitsSizeOf ty)) with SizeOfError _ -> @@ -68,8 +65,7 @@ [Int_Base.top]. ) let osizeof ty = (match ty with - | TVoid _ -> - CilE.warn_once "using size of 'void'" + | TVoid _ -> Kernel.warning ~once:true ~current:true "using size of 'void'" | _ -> ()) ; try Int_Base.inject (Int.of_int (warn_if_zero ty (bitsSizeOf ty) / 8)) @@ -81,9 +77,8 @@ meaningful. [true] means that the type is signed. *) let is_signed_int_enum_pointer ty = match unrollType ty with - | TInt (k,_) -> Cil.isSigned k + | TInt (k,_) | TEnum ({ekind=k},_) -> Cil.isSigned k | TPtr _ -> false - | TEnum _ -> theMachine.enum_are_signed | TFloat _ | TFun _ | TBuiltin_va_list _ | TVoid _ | TArray _ | TComp _ | TNamed _ -> raise Neither_Int_Nor_Enum_Nor_Pointer @@ -122,8 +117,8 @@ | TArray(typ,_,_,_) -> sizeof typ | _ -> Kernel.abort "TYPE IS: %a (unrolled as %a)" - !Ast_printer.d_type typ - !Ast_printer.d_type (unrollType typ) + !Ast_printer.d_type typ + !Ast_printer.d_type (unrollType typ) (** Returns the size of the type pointed by a pointer type in bytes. Never call it on a non pointer type. *) @@ -180,7 +175,7 @@ let raw_bits c start stop = let cond = env.use_align && ((not (Int.equal (Int.pos_rem start env.rh_size) align)) - || (not (Int.equal req_size env.rh_size))) + || (not (Int.equal req_size env.rh_size))) in Format.fprintf env.fmt "[%sbits %a to %a]%s" (if Kernel.debug_atleast 1 then String.make 1 c else "") @@ -205,14 +200,14 @@ | Other -> Int.of_int (bitsSizeOf typ) | Bitfield i -> Int.of_int64 i in - (if Int.is_zero start + (if Int.is_zero start && Int.equal size req_size then (** pretty print a full offset ) (if not env.use_align || - (Int.equal start align && Int.equal env.rh_size size) - then () - else (env.misaligned <- true ; - Format.pp_print_char env.fmt '#')) + (Int.equal start align && Int.equal env.rh_size size) + then () + else (env.misaligned <- true ; + Format.pp_print_char env.fmt '#')) else raw_bits 'b' start stop) @@ -244,16 +239,16 @@ else stop in let new_bfinfo = match field.fbitfield with - | None -> Other - | Some i -> Bitfield (Int.to_int64 (Int.of_int i)) + | None -> Other + | Some i -> Bitfield (Int.to_int64 (Int.of_int i)) in - let new_align = Int.pos_rem (Int.sub align start_o) env.rh_size in + let new_align = Int.pos_rem (Int.sub align start_o) env.rh_size in if Int.le new_start new_stop then - NamedField( field.fname , - new_bfinfo , field.ftype , - new_align , new_start , new_stop ) :: acc + NamedField( field.fname , + new_bfinfo , field.ftype , + new_align , new_start , new_stop ) :: acc else - acc) + acc) [] compinfo.cfields in @@ -272,42 +267,42 @@ else if Int.le succ_stop_o start then acc else if Int.gt start_o last_field_offset then ( found a hole ) - (RawField('c', last_field_offset,Int.pred start_o)::s, + (RawField('c', last_field_offset,Int.pred start_o)::s, succ_stop_o) else - (s,succ_stop_o) - ) - (full_fields_to_print,start) + (s,succ_stop_o) + ) + (full_fields_to_print,start) compinfo.cfields else full_fields_to_print, Int.zero in let overflowing = if compinfo.cstruct && Int.le succ_last stop - then RawField('o',Int.max start succ_last,stop)::non_covered + then RawField('o',Int.max start succ_last,stop)::non_covered else non_covered in let pretty_one_field = function - | NamedField(name,bf,ftyp,align,start,stop) -> - Format.fprintf env.fmt ".%a" !Ast_printer.d_ident name ; - pretty_bits_internal env bf ftyp ~align ~start ~stop - | RawField(c,start,stop) -> - Format.pp_print_char env.fmt '.' ; - raw_bits c start stop - in - let rec pretty_all_fields = function - | [] -> () - | f::fs -> - pretty_all_fields fs ; - pretty_one_field f ; - Format.pp_print_string env.fmt "; " - in - match overflowing with - | [] -> Format.pp_print_string env.fmt "{}" - | [f] -> pretty_one_field f - | fs -> - Format.pp_print_char env.fmt '{' ; - pretty_all_fields fs ; - Format.pp_print_char env.fmt '}' + | NamedField(name,bf,ftyp,align,start,stop) -> + Format.fprintf env.fmt ".%a" !Ast_printer.d_ident name ; + pretty_bits_internal env bf ftyp ~align ~start ~stop + | RawField(c,start,stop) -> + Format.pp_print_char env.fmt '.' ; + raw_bits c start stop + in + let rec pretty_all_fields = function + | [] -> () + | f::fs -> + pretty_all_fields fs ; + pretty_one_field f ; + Format.pp_print_string env.fmt "; " + in + match overflowing with + | [] -> Format.pp_print_string env.fmt "{}" + | [f] -> pretty_one_field f + | fs -> + Format.pp_print_char env.fmt '{' ; + pretty_all_fields fs ; + Format.pp_print_char env.fmt '}' end | TArray (typ, _, _, _) -> @@ -330,9 +325,9 @@ ~align:new_align ~start:rem_start_size ~stop:rem_stop_size - else if Int.equal (Int.rem start env.rh_size) align - && (Int.is_zero (Int.rem size env.rh_size)) - then + else if Int.equal (Int.rem start env.rh_size) align + && (Int.is_zero (Int.rem size env.rh_size)) + then let pred_size = Int.pred size in let start_full_case = if Int.is_zero rem_start_size then start_case @@ -345,45 +340,45 @@ let first_part = if Int.is_zero rem_start_size then [] else [ArrayPart(start_case,start_case, - typ,align,rem_start_size,pred_size)] + typ,align,rem_start_size,pred_size)] in let middle_part = if Int.lt stop_full_case start_full_case then [] else [ArrayPart(start_full_case,stop_full_case, - typ,align,Int.zero,pred_size)] + typ,align,Int.zero,pred_size)] in let last_part = if Int.equal rem_stop_size pred_size - then [] + then [] else [ArrayPart(stop_case,stop_case, - typ,align,Int.zero,rem_stop_size)] + typ,align,Int.zero,rem_stop_size)] + in + let do_part = function + | ArrayPart(start_index,stop_index,typ,align,start,stop) -> + if Int.equal start_index stop_index then + Format.fprintf env.fmt "[%a]" + Int.pretty start_index + else + Format.fprintf env.fmt "[%a..%a]" + Int.pretty start_index + Int.pretty stop_index ; + pretty_bits_internal env Other typ ~align ~start ~stop + in + let rec do_all_parts = function + | [] -> () + | p::ps -> + do_part p ; + Format.pp_print_string env.fmt "; " ; + do_all_parts ps in - let do_part = function - | ArrayPart(start_index,stop_index,typ,align,start,stop) -> - if Int.equal start_index stop_index then - Format.fprintf env.fmt "[%a]" - Int.pretty start_index - else - Format.fprintf env.fmt "[%a..%a]" - Int.pretty start_index - Int.pretty stop_index ; - pretty_bits_internal env Other typ ~align ~start ~stop - in - let rec do_all_parts = function - | [] -> () - | p::ps -> - do_part p ; - Format.pp_print_string env.fmt "; " ; - do_all_parts ps - in - match first_part @ middle_part @ last_part with - | [] -> Format.pp_print_string env.fmt "{}" - | [p] -> do_part p - | ps -> - Format.pp_print_char env.fmt '{' ; - do_all_parts ps ; - Format.pp_print_char env.fmt '}' ; + match first_part @ middle_part @ last_part with + | [] -> Format.pp_print_string env.fmt "{}" + | [p] -> do_part p + | ps -> + Format.pp_print_char env.fmt '{' ; + do_all_parts ps ; + Format.pp_print_char env.fmt '}' ; else raw_bits 'a' start stop @@ -407,6 +402,6 @@ ( Local Variables: -compile-command: "LC_ALL=C make -C ../.. -j" +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/misc/bit_utils.mli frama-c-20111001+nitrogen+dfsg/src/misc/bit_utils.mli --- frama-c-20110201+carbon+dfsg/src/misc/bit_utils.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/bit_utils.mli 2011-10-10 08:38:28.000000000 +0000 @@ -20,19 +20,18 @@ ( *) (**************************************************************************) -(* $Id: bit_utils.mli,v 1.11 2008-07-02 15:28:19 uid568 Exp $ *) - (** Some bit manipulations. *) open Cil_types -val sizeofchar: unit -> My_bigint.big_int +val sizeofchar: unit -> My_bigint.t (** [sizeof(char)] in bits *) val sizeofpointer: unit -> int (** [sizeof(char* )] in bits *) -val memory_size: unit -> My_bigint.big_int +val memory_size: unit -> My_bigint.t + (** Size of the addressable memory with pointers of size [sizeofpointer()] ) val sizeof: typ -> Int_Base.t ( [sizeof ty] is the size of [ty] in bits. This function may return @@ -41,11 +40,11 @@ val osizeof: typ -> Int_Base.t ( [osizeof ty] is the size of [ty] in bytes. This function may return [Int_Base.top]. ) - + exception Neither_Int_Nor_Enum_Nor_Pointer val is_signed_int_enum_pointer: typ -> bool - ( [true] means that the type is signed. + ( [true] means that the type is signed. @raise Neither_Int_Nor_Enum_Nor_Pointer if the sign of the type is not meaningful. *) @@ -79,13 +78,13 @@ (** {2 Pretty printing} *) -val pretty_bits: - typ -> +val pretty_bits: + typ -> use_align:bool -> - align:My_bigint.big_int -> - rh_size:My_bigint.big_int -> - start:My_bigint.big_int -> - stop:My_bigint.big_int -> Format.formatter -> bool + align:My_bigint.t -> + rh_size:My_bigint.t -> + start:My_bigint.t -> + stop:My_bigint.t -> Format.formatter -> bool (** Pretty prints a range of bits in a type for the user. Tries to find field names and array indexes, whenever possible. ) diff -Nru frama-c-20110201+carbon+dfsg/src/misc/filter.ml frama-c-20111001+nitrogen+dfsg/src/misc/filter.ml --- frama-c-20110201+carbon+dfsg/src/misc/filter.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/filter.ml 2011-10-10 08:38:28.000000000 +0000 @@ -20,20 +20,24 @@ ( *) (**************************************************************************) -open Db_types open Cil open Cil_types module FC_file = File (* overwritten by Cil_datatype ) open Cil_datatype open Extlib +let dkey = "filter" + +let debug1 fmt = Kernel.debug ~dkey fmt +let debug2 fmt = Kernel.debug ~dkey ~level:2 fmt + module type T_RemoveInfo = sig type t_proj type t_fct exception EraseAssigns - val fct_info : t_proj -> Db_types.kernel_function -> t_fct list + val fct_info : t_proj -> kernel_function -> t_fct list val fct_name : varinfo -> t_fct -> string @@ -43,8 +47,7 @@ val inst_visible : t_fct -> stmt -> bool val label_visible : t_fct -> stmt -> label -> bool - val annotation_visible: t_fct -> stmt -> before:bool -> - code_annotation -> bool + val annotation_visible: t_fct -> stmt -> code_annotation -> bool val fun_precond_visible : t_fct -> predicate -> bool val fun_postcond_visible : t_fct -> predicate -> bool @@ -53,14 +56,15 @@ val fun_deps_visible : t_fct -> identified_term -> bool val called_info : (t_proj t_fct) -> stmt -> - (Db_types.kernel_function * t_fct) option + (kernel_function * t_fct) option val res_call_visible : t_fct -> stmt -> bool - val result_visible : Db_types.kernel_function -> t_fct -> bool + val result_visible : kernel_function -> t_fct -> bool end module F (Info : T_RemoveInfo) : sig val build_cil_file : string -> Info.t_proj -> Project.t + end = struct type t = (string, Cil_types.varinfo) Hashtbl.t @@ -69,12 +73,28 @@ let mk_skip loc = Instr (Skip loc) let mk_stmt_skip st = mk_skip (Stmt.loc st) + let make_new_kf tbl kf v = + try + Cil_datatype.Varinfo.Hashtbl.find tbl v + with Not_found -> + let fundec = + match kf.fundec with + | Definition(f,l) -> Definition ( { f with svar = v },l) + | Declaration(_,_,arg,l) -> + Declaration(Cil.empty_funspec(),v,arg,l) + in + let kf = + { fundec = fundec; spec = Cil.empty_funspec(); return_stmt = None } + in + Cil_datatype.Varinfo.Hashtbl.add tbl v kf; kf + let rec can_skip keep_stmts stmt = + stmt.labels = [] && match stmt.skind with | Instr (Skip _) -> - Kernel.debug ~level:2 "@[Statement %d: can%s skip@]@." stmt.sid + debug2 "@[Statement %d: can%s skip@]@." stmt.sid (if Stmt.Set.mem stmt keep_stmts then "'t" else ""); - not (Stmt.Set.mem stmt keep_stmts) && stmt.labels = [] + not (Stmt.Set.mem stmt keep_stmts) | Block b -> is_empty_block keep_stmts b | UnspecifiedSequence seq -> is_empty_unspecified_sequence keep_stmts seq | _ -> false @@ -85,20 +105,27 @@ and is_empty_unspecified_sequence keep_stmts seq = List.for_all ((can_skip keep_stmts) $ (fun (x,_,_,_,_)->x)) seq - let rec mk_new_block keep_stmts s b loc = + let rec mk_new_block keep_stmts s blk loc = (* vblock has already cleaned up the statements (removed skip, etc...), * but now the block can still be empty or include only one statement. ) - match b.bstmts with - | [] | _ when is_empty_block keep_stmts b -> + match blk.bstmts with + | [] | _ when is_empty_block keep_stmts blk -> + ( don't care about local variables since the block is empty. ) mk_new_stmt s (mk_skip loc) - | stmt :: [] -> ( one statement only ) - begin match stmt.skind with - | Block b -> mk_new_block keep_stmts s b loc - | UnspecifiedSequence seq -> - mk_new_unspecified_sequence keep_stmts s seq loc - | _ -> mk_new_stmt s stmt.skind + | { labels = [] } as s1 :: [] -> + ( one statement only, and no label ) + begin + match s1.skind with + | Block b -> + ( drop blk, but keep local declarations. ) + b.blocals <- b.blocals @ blk.blocals; + mk_new_block keep_stmts s b loc + | UnspecifiedSequence seq when blk.blocals = [] -> + mk_new_unspecified_sequence keep_stmts s seq loc + | _ when blk.blocals = [] -> mk_new_stmt s s1.skind + | _ -> mk_new_stmt s (Block blk) end - | _ -> mk_new_stmt s (Block b) + | _ -> mk_new_stmt s (Block blk) ( same as above, but for unspecified sequences. ) and mk_new_unspecified_sequence keep_stmts s seq loc = @@ -109,7 +136,9 @@ | _ when is_empty_unspecified_sequence keep_stmts seq -> mk_new_stmt s (mk_skip loc) | [stmt,_,_,_,_] -> ( one statement only ) - begin match stmt.skind with + begin + if stmt.labels <> [] then s.labels <- s.labels @ stmt.labels; + match stmt.skind with | UnspecifiedSequence seq -> mk_new_unspecified_sequence keep_stmts s seq loc | Block b -> mk_new_block keep_stmts s b loc @@ -117,12 +146,51 @@ end | _ -> mk_new_stmt s (UnspecifiedSequence seq) - let rec filter_labels finfof st labels = match labels with - | [] -> [] - | l :: labs -> - if Info.label_visible finfof st l - then l::(filter_labels finfof st labs) - else filter_labels finfof st labs + let add_label_if_needed mk_label finfo s = + let rec pickLabel = function + | [] -> None + | Label _ as lab :: _ when Info.label_visible finfo s lab -> Some lab + | _ :: rest -> pickLabel rest + in match pickLabel s.labels with + | Some _ -> None + | None -> + let label = mk_label (Cil_datatype.Stmt.loc s) in + debug2 "add label to sid:%d : %a" s.sid Cil.d_label label; + s.labels <- label::s.labels; + Some label + + let rm_break_cont ?(cont=true) ?(break=true) mk_label finfo blk = + let change loc s = + let dest = match s.succs with dest::_ -> dest | [] -> assert false in + let new_l = add_label_if_needed mk_label finfo dest in + mk_new_stmt s (Goto (ref dest, loc)); + debug2 "changed break/continue into @[%a@]@." + !Ast_printer.d_stmt s; + new_l + in + let rec rm_aux cont break s = + match s.skind with + | Break loc when break && Info.inst_visible finfo s -> + let _ = change loc s in () + | Continue loc when cont && Info.inst_visible finfo s -> + let _ = change loc s in () + | Instr _ | Return _ | Break _ | Continue _ | Goto _ -> () + | If (_, bthen, belse, _) -> + List.iter (rm_aux cont break) bthen.bstmts; + List.iter (rm_aux cont break) belse.bstmts; + | Block blk -> + List.iter (rm_aux cont break) blk.bstmts + | UnspecifiedSequence seq -> + let blk = Cil.block_from_unspecified_sequence seq in + List.iter (rm_aux cont break) blk.bstmts + | Loop _ -> ( don't go inside : break and continue change meaning) + () + | Switch (_, blk, _, _) -> + ( if change [continue] do it, but stop changing [break] ) + if cont then + let break = false in List.iter (rm_aux cont break) blk.bstmts + | TryFinally _ | TryExcept _ -> ( TODO ? *) () + in List.iter (rm_aux cont break) blk.bstmts (** filter [params] according to [ff] input visibility. * Can be used to slice both the parameters, the call arguments, @@ -146,8 +214,7 @@ let name = Info.fct_name fct_var finfo in try let ff_var = Hashtbl.find fun_vars name in - Kernel.debug ~level:2 - "[filter:ff_var] Use fct var %s:%d@." ff_var.vname ff_var.vid; + debug2 "[ff_var] Use fct var %s:%d@." ff_var.vname ff_var.vid; ff_var with Not_found -> let ff_var = Cil.copyVarinfo fct_var name in @@ -155,33 +222,71 @@ Cil.setReturnTypeVI ff_var Cil.voidType; (* Notice that we don't have to filter the parameter types here : * they will be update by [Cil.setFormals] later on. ) - Kernel.debug ~level:2 "[filter:ff_var] Mem fct var %s:%d@." - ff_var.vname ff_var.vid; + debug2 "[ff_var] Mem fct var %s:%d@." + ff_var.vname ff_var.vid; Hashtbl.add fun_vars name ff_var; ff_var - let optim_if keep_stmts s cond_opt bthen belse loc = + let optim_if keep_stmts s_orig s cond_opt bthen belse loc = let empty_then = is_empty_block keep_stmts bthen in let empty_else = is_empty_block keep_stmts belse in - Kernel.debug ~level:2 "[filter:optim_if] sid:%d with \ - %s cond, %s empty then, %s empty else@." - s.sid + debug2 "[optim_if] @[sid:%d (orig:%d)@ \ + with %s cond, %s empty then, %s empty else@]@." + s.sid s_orig.sid (if cond_opt = None then "no" else "") (if empty_then then "" else "not") (if empty_else then "" else "not"); - match cond_opt, empty_then, empty_else with - | _, true,true -> ( both blocks empty -> skip ) - mk_new_stmt s (mk_skip loc) - | None, false, true -> ( no cond and else empty -> block then ) - (mk_new_block keep_stmts s bthen loc) - | None, true, false -> ( no cond and then empty -> block else ) - (mk_new_block keep_stmts s belse loc) - | Some cond, _, _ -> - let skind = If (cond, bthen, belse, loc) in - (mk_new_stmt s skind) - | None, false, false -> - let skind = If (Cil.zero ~loc, bthen, belse, loc) in - (mk_new_stmt s skind) + match cond_opt with + | Some cond -> + if empty_then && empty_else then mk_new_stmt s (mk_skip loc) + else ( cond visible and something in blocks : keep if ) + mk_new_stmt s (If (cond, bthen, belse, loc)) + | None -> ( no cond ) + let go_then, go_else = Db.Value.condition_truth_value s_orig in + debug2 + "[condition_truth_value] can go in then = %b - can go in else =%b@." + go_then go_else; + match go_then, empty_then, go_else, empty_else with + | _, true, _, true -> ( both blocks empty -> skip ) + mk_new_stmt s (mk_skip loc) + | true, false, false, true -> + ( else empty and always go to then -> block then ) + mk_new_block keep_stmts s bthen loc + | false, true, true, false -> + ( then empty and always go to else -> block else ) + mk_new_block keep_stmts s belse loc + | false, false, true, _ -> + ( always goes in the 'else' branch, + * but the then branch is not empty : ) + mk_new_stmt s (If (Cil.zero ~loc, bthen, belse, loc)) + | true, false, false, false -> + ( always goes in the 'then' branch, + * but the else branch is not empty : + ) + mk_new_stmt s (If (Cil.one ~loc, bthen, belse, loc)) + | true, true, false, false -> + ( always goes in the 'then' empty branch, + * but the else branch is not empty : + * build (if (0) belse else empty. + ) + mk_new_stmt s (If (Cil.zero ~loc, belse, bthen, loc)) + | true, false, true, false + | false, false, false, false -> + ( if both go_then and go_else are true: + * can go in both branch but don't depend on cond ? + * probably unreachable IF with reachable blocks by goto. + * if both go_else and go_else are false: + * never goes in any branch ? + * both branch visible -> dummy condition ) + mk_new_stmt s (If (Cil.one ~loc, bthen, belse, loc)) + | true, _, true, true + | false, _, false, true -> + ( can go in both or no branch (see above) : empty else ) + mk_new_block keep_stmts s bthen loc + | true, true, true, _ + | false, true, false, _ -> + ( can go in both or no branch (see above) : empty then *) + mk_new_block keep_stmts s belse loc let visible_lval vars_visible lval = let visitor = object @@ -222,6 +327,23 @@ val fun_vars = Hashtbl.create 7 val local_visible = Varinfo.Hashtbl.create 7 val formals_table = Varinfo.Hashtbl.create 7 + val my_kf = Varinfo.Hashtbl.create 7 + + val lab_num = ref 0; + val lab_prefix = "break_cont" + method private fresh_label loc = + incr lab_num; + let lname = Printf.sprintf "%s_%d" lab_prefix !lab_num in + Label (lname, loc, false) + method private is_our_label label = match label with + | Label (lname, _, false) -> + let ok = + try + let prefix = String.sub lname 0 (String.length lab_prefix) in + prefix = lab_prefix + with Invalid_argument _ -> false + in ok + | _ -> false method private get_finfo () = Extlib.the fi @@ -229,8 +351,8 @@ keep_stmts <- Stmt.Set.add stmt keep_stmts (** Applied on each variable use : - * must replace references to formal/local variables - * and source function calls ) + must replace references to formal/local variables + * and source function calls ) method vvrbl (v: varinfo) = if v.vglob then @@ -270,8 +392,7 @@ | [] -> [] | var :: locals -> let visible = Info.loc_var_visible (self#get_finfo ()) var in - Kernel.debug ~level:2 - "[filter:local] %s -> %s@." var.vname + debug2 "[local] %s -> %s@." var.vname (if visible then "keep" else "remove"); if visible then begin @@ -294,23 +415,21 @@ let stmt = Cil.get_original_stmt self#behavior (Cilutil.valOf self#current_stmt) in - let before = self#is_annot_before in - Kernel.debug "[filter:annotation] %s stmt %d : %a @." - (if before then "before" else "after") + debug1 "[annotation] stmt %d : %a @." stmt.sid !Ast_printer.d_code_annotation v; - if Db.Value.is_accessible (Cil_types.Kstmt stmt) && - Info.annotation_visible (self#get_finfo ()) stmt before v + if Db.Value.is_reachable_stmt stmt && + Info.annotation_visible (self#get_finfo ()) stmt v then begin self#add_stmt_keep stmt; ChangeDoChildrenPost (v,Logic_const.refresh_code_annotation) end else begin - Kernel.debug "\t-> ignoring annotation: %a@." + debug1 "\t-> ignoring annotation: %a@." !Ast_printer.d_code_annotation v; ChangeTo (Logic_const.new_code_annotation (AAssert ([], - { name = []; loc = Lexing.dummy_pos,Lexing.dummy_pos; - content = Ptrue}))) + { name = []; loc = Lexing.dummy_pos,Lexing.dummy_pos; + content = Ptrue}))) end method private process_call call_stmt call = @@ -327,7 +446,7 @@ let need_lval = Info.res_call_visible finfo call_stmt in let new_lval = if need_lval then lval else None in let new_call = Call (new_lval, new_funcexp, new_args, loc) in - Kernel.debug "[filter:process_call] call %s@." var_slice.vname; + debug1 "[process_call] call %s@." var_slice.vname; Instr (new_call) method vblock (b: block) = @@ -341,9 +460,9 @@ b'.bstmts <- List.filter (fun st -> - not (Cil.is_skip st.skind) - || st.labels <> [] - || Annotations.get_all st <> [] + not (Cil.is_skip st.skind) + || st.labels <> [] + || Annotations.get_all st <> [] (|| ((Format.eprintf "Skipping %d@.@." st.sid;) false)) ) b'.bstmts) @@ -366,11 +485,11 @@ Cil.set_stmt self#behavior orig s; Cil.set_orig_stmt self#behavior s orig; if keep then self#add_stmt_keep s; - Kernel.debug ~level:2 - "@[finalize %d->%d = %a@]@\n@." old s.sid !Ast_printer.d_stmt s; + debug2 "@[finalize sid:%d->sid:%d@]@\n@." old s.sid method private process_invisible_stmt s = - Kernel.debug ~level:2 "[filter:process_invisible_stmt] sid:%d@." s.sid; + let finfo = self#get_finfo () in + debug2 "[process_invisible_stmt] does sid:%d@." s.sid; ( invisible statement : but still have to visit the children if any ) let oldskind = s.skind in let do_after s = @@ -380,41 +499,45 @@ | If (_,bthen,belse,loc) -> let bthen = Cil.visitCilBlock (self:>Cil.cilVisitor) bthen in let belse = Cil.visitCilBlock (self:>Cil.cilVisitor) belse in - optim_if keep_stmts s None bthen belse loc + let s_orig = Cil.get_original_stmt self#behavior s in + optim_if keep_stmts s_orig s None bthen belse loc | Switch (_exp, body, _, loc) -> ( the switch is invisible : it can be translated into a block. ) + rm_break_cont ~cont:false (self#fresh_label) finfo body; let block = Cil.visitCilBlock (self:>Cil.cilVisitor) body in (mk_new_block keep_stmts s block loc) - | Loop (_, body, loc, _yst1, _st2) -> - ( the loop test is invisible : - * the body it can be translated into a simple block. ) + | Loop (_, body, loc, _lcont, _lbreak) -> + rm_break_cont (self#fresh_label) finfo body; let bloop = Cil.visitCilBlock (self:>Cil.cilVisitor) body in - (mk_new_block keep_stmts s bloop loc) + mk_new_block keep_stmts s bloop loc | Block _ | UnspecifiedSequence _ -> assert false ( a block is always visible ) | TryFinally _ | TryExcept _ -> assert false (TODO) | Return (_,l) -> mk_new_stmt s (Return (None,l)) | _ -> mk_new_stmt s (mk_stmt_skip s)); + debug2 "@[<hov 10>[process_invisible_stmt] gives sid:%d@ @[%a@]@]@." + s.sid !Ast_printer.d_stmt s; s in s.skind <- mk_stmt_skip s; ChangeDoChildrenPost(s, do_after) method private process_visible_stmt s = - Kernel.debug ~level:2 "[filter:process_visible_stmt] sid:%d@." s.sid; + debug2 "[process_visible_stmt] does sid:%d@." s.sid; (match s.skind with - | Instr (Call (lval, funcexp, args, loc)) -> - let call = (lval, funcexp, args, loc) in - let new_call = self#process_call s call in - mk_new_stmt s new_call - | _ -> () ( copy the statement before modifying it ) - ( mk_new_stmt s [] s.skind ) + | Instr (Call (lval, funcexp, args, loc)) -> + let call = (lval, funcexp, args, loc) in + let new_call = self#process_call s call in + mk_new_stmt s new_call + | _ -> () ( copy the statement before modifying it ) + ( mk_new_stmt s [] s.skind ) ); let do_after s' = self#change_sid s'; (match s'.skind with | If (cond,bthen,belse,loc) -> - optim_if keep_stmts s' (Some cond) bthen belse loc + let s_orig = Cil.get_original_stmt self#behavior s' in + optim_if keep_stmts s_orig s' (Some cond) bthen belse loc | Switch (e,b,c,l) -> let c' = List.filter (not $ (can_skip keep_stmts)) c in s'.skind <- Switch(e,b,c',l) @@ -458,21 +581,31 @@ | _ -> ()) self#get_filling_actions | _ -> ()); + debug2 "@[<hov 10>[process_visible_stmt] gives sid:%d@ @[%a@]@]@." + s'.sid !Ast_printer.d_stmt s'; s' in Cil.ChangeDoChildrenPost (s, do_after) method vstmt_aux s = let finfo = self#get_finfo () in - let labels = filter_labels finfo s s.labels in + let rec filter_labels labels = match labels with + | [] -> [] + | l :: labs -> + let keep = Info.label_visible finfo s l || self#is_our_label l in + debug2 "[filter_labels] %svisible %a@." + (if keep then "" else "in") Cil.d_label l; + if keep then l::(filter_labels labs) else filter_labels labs + in + let labels = filter_labels s.labels in s.labels <- labels; match s.skind with - | Block _ | UnspecifiedSequence _ -> self#process_visible_stmt s - | _ when Info.inst_visible finfo s -> self#process_visible_stmt s - | _ -> self#process_invisible_stmt s + | Block _ | UnspecifiedSequence _ -> self#process_visible_stmt s + | _ when Info.inst_visible finfo s -> self#process_visible_stmt s + | _ -> self#process_invisible_stmt s method vfunc f = - Kernel.debug "@[[filter:vfunc] -> %s@\n@]@." f.svar.vname; + debug1 "@[[vfunc] -> %s@\n@]@." f.svar.vname; fi <- Some (Varinfo.Hashtbl.find fi_table f.svar); ( parameters ) let new_formals = @@ -529,8 +662,8 @@ let ensure_visible (_,p) = Info.fun_postcond_visible finfo p.ip_content in b.b_post_cond <- - filter_list ensure_visible (fun (k,p) -> k,self#visit_pred p) - b.b_post_cond; + filter_list ensure_visible (fun (k,p) -> k,self#visit_pred p) + b.b_post_cond; let from_visible a = Info.fun_assign_visible finfo a in let from_visit a = visitCilFrom (self:>Cil.cilVisitor) a in @@ -545,23 +678,23 @@ SkipChildren ( see the warning on [SkipChildren] in [vspec] ! ) method vspec spec = - Kernel.debug "@[[filter:vspec] for %a @\n@]@." - Kernel_function.pretty_name (Extlib.the self#current_kf); + debug1 "@[[vspec] for %a @\n@]@." + Kernel_function.pretty (Extlib.the self#current_kf); let finfo = self#get_finfo () in let b = Cil.visitCilBehaviors (self:>Cil.cilVisitor) spec.spec_behavior in let b = List.filter (not $ Cil.is_empty_behavior) b in spec.spec_behavior <- b; let new_variant = match spec.spec_variant with - | None -> None - | Some (t,n) -> if Info.fun_variant_visible finfo t + | None -> None + | Some (t,n) -> if Info.fun_variant_visible finfo t then Some (visitCilTerm (self:>Cil.cilVisitor) t, n) else None in spec.spec_variant <- new_variant ; let new_term = match spec.spec_terminates with - | None -> None - | Some p -> if Info.fun_precond_visible finfo p.ip_content + | None -> None + | Some p -> if Info.fun_precond_visible finfo p.ip_content then Some (self#visit_pred p) else None in @@ -579,11 +712,12 @@ let kf = Extlib.the self#current_kf in fi <- Some finfo; let new_var = ff_var fun_vars kf finfo in + let new_kf = make_new_kf my_kf kf new_var in Varinfo.Hashtbl.add fi_table new_var finfo; - Kernel.debug "@[[filter:build_cil_proto] -> %s@\n@]@." new_var.vname; + debug1 "@[[build_cil_proto] -> %s@\n@]@." new_var.vname; let action = - let (rt,args,va,attrs) = Cil.splitFunctionType new_var.vtype in - let () = + let (rt,args,va,attrs) = Cil.splitFunctionType new_var.vtype in + let () = match args with None -> () | Some args -> @@ -610,17 +744,19 @@ Queue.add (fun () -> Cil.unsafeSetFormalsDecl new_var new_formals) self#get_filling_actions - in - let res = Cil.visitCilFunspec (self:>Cil.cilVisitor) kf.spec in - let action () = + in + let res = Cil.visitCilFunspec (self:>Cil.cilVisitor) kf.spec in + let action () = ( Replace the funspec copied by the default visitor, as varinfo of formals would not be taken into account correctly - otherwise (everything would be mapped to the last set of + otherwise: everything would be mapped to the last set of formals... ) - Queue.add (fun () -> let kf = Globals.Functions.get new_var in - kf.spec <- res) self#get_filling_actions - in action + Queue.add + (fun () -> + !Globals.Functions.set_spec new_kf (fun _ -> res)) + self#get_filling_actions + in action (end else fun () -> ()) in let orig_var = Ast_info.Function.get_vi kf.fundec in @@ -628,18 +764,22 @@ by ff_var but directly by the visitor ) if (Cil.get_varinfo self#behavior orig_var) == orig_var then - Cil.set_varinfo self#behavior orig_var new_var; + Cil.set_varinfo self#behavior orig_var new_var; (* Set the new_var as an already known one, coming from the vi associated to the current kf. ) Cil.set_varinfo self#behavior new_var new_var; Cil.set_orig_varinfo self#behavior new_var orig_var; + Cil.set_kernel_function self#behavior kf new_kf; + Cil.set_orig_kernel_function self#behavior new_kf kf; + Queue.add + (fun () -> Globals.Functions.register new_kf) self#get_filling_actions; GVarDecl (Cil.empty_funspec(), new_var, loc), action method private compute_fct_prototypes (_fct_var,loc) = let finfo_list = Info.fct_info pinfo (Extlib.the self#current_kf) in - Kernel.debug "@[[filter:compute_fct_prototypes] for %a (x%d)@\n@]@." - Kernel_function.pretty_name (Extlib.the self#current_kf) + debug1 "@[[compute_fct_prototypes] for %a (x%d)@\n@]@." + Kernel_function.pretty (Extlib.the self#current_kf) (List.length finfo_list); let build_cil_proto finfo = self#build_proto finfo loc in List.map build_cil_proto finfo_list @@ -647,44 +787,52 @@ method private compute_fct_definitions f loc = let fvar = f.Cil_types.svar in let finfo_list = Info.fct_info pinfo (Extlib.the self#current_kf) in - Kernel.debug "@[[filter:compute_fct_definitions] for %a (x%d)@\n@]@." - Kernel_function.pretty_name - (Extlib.the self#current_kf) (List.length finfo_list); + debug1 "@[[compute_fct_definitions] for %a (x%d)@\n@]@." + Kernel_function.pretty + (Extlib.the self#current_kf) (List.length finfo_list); let do_f finfo = - if not (Info.body_visible finfo) then + if not (Info.body_visible finfo) then self#build_proto finfo loc - else begin - let new_fct_var = ff_var fun_vars (Extlib.the self#current_kf) finfo in + else begin + let kf = Extlib.the self#current_kf in + let new_fct_var = ff_var fun_vars kf finfo + in + let new_kf = make_new_kf my_kf kf new_fct_var in ( Set the new_var as an already known one, * coming from the vi associated to the current kf. ) Cil.set_varinfo self#behavior new_fct_var new_fct_var; Cil.set_orig_varinfo self#behavior new_fct_var fvar; + Cil.set_kernel_function self#behavior kf new_kf; + Cil.set_orig_kernel_function self#behavior new_kf kf; + Queue.add + (fun () -> Globals.Functions.register new_kf) + self#get_filling_actions; Varinfo.Hashtbl.add fi_table new_fct_var finfo; - Kernel.debug "@[[filter:build_cil_fct] -> %s@\n@]@." + debug1 "@[[build_cil_fct] -> %s@\n@]@." (Info.fct_name - (Kernel_function.get_vi (Extlib.the self#current_kf)) finfo); + (Kernel_function.get_vi (Extlib.the self#current_kf)) finfo); let action () = Queue.add (fun () -> - let kf = Globals.Functions.get new_fct_var in - kf.spec <- Varinfo.Hashtbl.find spec_table new_fct_var) + !Globals.Functions.set_spec new_kf + (fun _ -> Varinfo.Hashtbl.find spec_table new_fct_var)) self#get_filling_actions in let f = {f with svar = new_fct_var} in - ( [JS 2009/03/23] do not call self#vfunc in the assertion; - otherwise does not work whenever frama-c is compiled with - -no-assert ) - let res = self#vfunc f in - assert (res = SkipChildren); + ( [JS 2009/03/23] do not call self#vfunc in the assertion; + otherwise does not work whenever frama-c is compiled with + -no-assert ) + let res = self#vfunc f in + assert (res = SkipChildren); ( if this ever changes, we must do some work. ) GFun (f,loc), action - end + end in List.map do_f finfo_list method vglob_aux g = let post action g = List.iter (fun x -> x()) action; fi <- None; - Kernel.debug "[filter:post action] done.@."; + debug1 "[post action] done.@."; g in match g with @@ -697,24 +845,24 @@ begin match Cil.unrollType v.vtype with | TFun _ -> - Kernel.debug "[filter:vglob_aux] GVarDecl %s (TFun)@." v.vname; + debug1 "[vglob_aux] GVarDecl %s (TFun)@." v.vname; let var_decl = (v, loc) in let (new_decls,actions) = List.split (self#compute_fct_prototypes var_decl) in Cil.ChangeToPost (new_decls, post actions) | _ -> - Kernel.debug "[filter:vglob_aux] GVarDecl %s (other)@." v.vname; + debug1 "[vglob_aux] GVarDecl %s (other)@." v.vname; Cil.DoChildren end | _ -> Cil.DoChildren end let build_cil_file new_proj_name pinfo = - Kernel.debug "[filter:build_cil_file] in %s@." new_proj_name; + debug1 "[build_cil_file] in %s@." new_proj_name; let visitor = new filter_visitor pinfo in let prj = FC_file.create_project_from_visitor new_proj_name visitor in - Kernel.debug "[filter:build_cil_file] done.@."; + debug1 "[build_cil_file] done.@."; prj end diff -Nru frama-c-20110201+carbon+dfsg/src/misc/filter.mli frama-c-20111001+nitrogen+dfsg/src/misc/filter.mli --- frama-c-20110201+carbon+dfsg/src/misc/filter.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/filter.mli 2011-10-10 08:38:28.000000000 +0000 @@ -31,7 +31,7 @@ have to be visible or not ) module type T_RemoveInfo = sig - ( exception that fun_assign_visible should raise to indicate that + ( exception that fun_assign_visible should raise to indicate that the corresponding assigns clause should be erased entirely ) exception EraseAssigns @@ -45,7 +45,7 @@ (** This function will be called for each function of the source program. * A new function will be created for each element of the returned list. *) - val fct_info : t_proj -> Db_types.kernel_function -> t_fct list + val fct_info : t_proj -> kernel_function -> t_fct list (** useful when we want to have several functions in the result for one * source function. If if is not the case, you can return [varinfo.vname]. @@ -70,17 +70,15 @@ (** tells if the label is visible. *) val label_visible : t_fct -> stmt -> label -> bool - (** tells if the annotation, attached to the given statement - (before when the flag is true, after otherwise) is visible. *) - val annotation_visible: t_fct -> stmt -> before:bool -> - code_annotation -> bool + (** tells if the annotation, attached to the given statement is visible. ) + val annotation_visible: t_fct -> stmt -> code_annotation -> bool val fun_precond_visible : t_fct -> predicate -> bool val fun_postcond_visible : t_fct -> predicate -> bool val fun_variant_visible : t_fct -> term -> bool val fun_assign_visible : t_fct -> identified_term from -> bool - ( true if the assigned value (first component of the from) is visible + ( true if the assigned value (first component of the from) is visible @raise EraseAssigns to indicate that the corresponding assigns clause should be erased entirely (i.e. assigns everything. If it were to just return false to all elements, this would result in assigns \nothing @@ -95,7 +93,7 @@ The input [t_fct] parameter is the one of the caller function. * ) val called_info : t_proj t_fct -> stmt -> - (Db_types.kernel_function * t_fct) option + (kernel_function * t_fct) option (** tells if the lvalue of the call has to be visible ) val res_call_visible : t_fct -> stmt -> bool @@ -110,7 +108,7 @@ - [res_call_visible] must return [false] * if [result_visible] returns false on the called function. ) - val result_visible : Db_types.kernel_function -> t_fct -> bool + val result_visible : kernel_function -> t_fct -> bool end diff -Nru frama-c-20110201+carbon+dfsg/src/misc/service_graph.ml frama-c-20111001+nitrogen+dfsg/src/misc/service_graph.ml --- frama-c-20110201+carbon+dfsg/src/misc/service_graph.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/service_graph.ml 2011-10-10 08:38:28.000000000 +0000 @@ -28,7 +28,7 @@ val id: t -> int val name: t -> string val attributes: t -> Graph.Graphviz.DotAttributes.vertex list - val entry_point: unit -> t + val entry_point: unit -> t option end val iter_vertex : (V.t -> unit) -> t -> unit val iter_succ : (V.t -> unit) -> t -> V.t -> unit @@ -61,21 +61,21 @@ include M module Datatype = Datatype.Make - (struct - ( [JS 2010/09/27] TODO: do better? ) - include Datatype.Serializable_undefined - type t = M.t - let name = G.datatype_name ^ " Service_graph.CallG.t" - let reprs = [ M.create () ] - let mem_project = Datatype.never_any_project - end) + (struct + ( [JS 2010/09/27] TODO: do better? ) + include Datatype.Serializable_undefined + type t = M.t + let name = G.datatype_name ^ " Service_graph.CallG.t" + let reprs = [ M.create () ] + let mem_project = Datatype.never_any_project + end) let () = Type.set_ml_name Datatype.ty None let add_labeled_edge g src l dst = if mem_edge g src dst then begin - remove_edge g src dst; - add_edge_e g (E.create src Both dst) + remove_edge g src dst; + add_edge_e g (E.create src Both dst) end else - add_edge_e g (E.create src l dst) + add_edge_e g (E.create src l dst) end type root = Is_root | In_service of vertex @@ -98,25 +98,25 @@ let edge_invariant src dst = function | Inter_functions -> assert - (if Vertex.equal src.root dst.root || dst.is_root then - true - else begin + (if Vertex.equal src.root dst.root || dst.is_root then + true + else begin Format.printf - "Src:%s in %s (is_root:%b) Dst:%s in %s (is_root:%b)@." + "Src:%s in %s (is_root:%b) Dst:%s in %s (is_root:%b)@." (G.V.name src.node) (G.V.name src.root.node) src.is_root (G.V.name dst.node) (G.V.name dst.root.node) dst.is_root; - false - end) + false + end) | Inter_services | Both -> assert (src.is_root && dst.is_root) let check_invariant callg = CallG.iter_edges_e (fun e -> - edge_invariant (CallG.E.src e) (CallG.E.dst e) (CallG.E.label e)) + edge_invariant (CallG.E.src e) (CallG.E.dst e) (CallG.E.label e)) callg let mem initial_roots node = @@ -126,34 +126,36 @@ exception Cannot_merge let merge_service s1 s2 = match s1, s2 with | Fresh_if_unchanged, (Maybe_fresh v2 | In_service v2) -> - To_be_confirmed v2 + To_be_confirmed v2 | (To_be_confirmed v1 | Final v1), In_service v2 when Vertex.equal v1 v2 -> - s1 + s1 | (To_be_confirmed v1 | Final v1), Maybe_fresh v2 - when Vertex.equal v1 v2 -> - To_be_confirmed v2 + when Vertex.equal v1 v2 -> + To_be_confirmed v2 | (To_be_confirmed v1 | Final v1), (Maybe_fresh v2 | In_service v2) -> - assert (not (Vertex.equal v1 v2)); - raise Cannot_merge + assert (not (Vertex.equal v1 v2)); + raise Cannot_merge let entry_point_ref = ref None let make_vertex g callg initial_roots node = let mk incomming_s = let v = match incomming_s with - | Fresh_if_unchanged -> - let rec v = { node = node; is_root = true; root = v } in v - | To_be_confirmed root | Final root -> - { node = node; is_root = false; root = root } + | Fresh_if_unchanged -> + let rec v = { node = node; is_root = true; root = v } in v + | To_be_confirmed root | Final root -> + { node = node; is_root = false; root = root } in - if G.V.equal node (G.V.entry_point ()) then entry_point_ref := Some v; + (match G.V.entry_point () with + | Some e when G.V.equal node e -> entry_point_ref := Some v + | None | Some _ -> ()); let s = match incomming_s with - | Fresh_if_unchanged | Final _ -> In_service v.root - | To_be_confirmed root -> Maybe_fresh root + | Fresh_if_unchanged | Final _ -> In_service v.root + | To_be_confirmed root -> Maybe_fresh root in - ( Format.printf "%s; root %s; final: %b@." - (G.V.name node) (G.V.name v.root.node) - (match s with In_service _ -> true | Maybe_fresh _ -> false);) + ( Format.printf "%s; root %s; final: %b@." + (G.V.name node) (G.V.name v.root.node) + (match s with In_service _ -> true | Maybe_fresh _ -> false);) Vertices.add node (v, s); CallG.add_vertex callg v in @@ -161,23 +163,23 @@ mk Fresh_if_unchanged else try - let service = - G.fold_pred - (fun node' acc -> - try - let _, s' = Vertices.find node' in - merge_service acc s' - with Not_found -> - acc) - g - node - Fresh_if_unchanged - in - ( if Fresh_if_unchanged at this point, - either node without predecessor or dominator cycle detected ) - mk service + let service = + G.fold_pred + (fun node' acc -> + try + let _, s' = Vertices.find node' in + merge_service acc s' + with Not_found -> + acc) + g + node + Fresh_if_unchanged + in + ( if Fresh_if_unchanged at this point, + either node without predecessor or dominator cycle detected ) + mk service with Cannot_merge -> - mk Fresh_if_unchanged + mk Fresh_if_unchanged let update_vertex g node = try @@ -185,22 +187,22 @@ match s with | In_service root -> assert (Vertex.equal v.root root) | Maybe_fresh root -> - assert (Vertex.equal v.root root); - try - G.iter_pred - (fun node' -> - try - let v', _ = Vertices.find node' in - if not (Vertex.equal root v'.root) then raise Exit - with Not_found -> - assert false) - g - node - ( old status is confirmed: nothing to do ) - with Exit -> - ( update ) - v.is_root <- true; - v.root <- v + assert (Vertex.equal v.root root); + try + G.iter_pred + (fun node' -> + try + let v', _ = Vertices.find node' in + if not (Vertex.equal root v'.root) then raise Exit + with Not_found -> + assert false) + g + node + ( old status is confirmed: nothing to do ) + with Exit -> + ( update ) + v.is_root <- true; + v.root <- v with Not_found -> assert false @@ -210,24 +212,24 @@ in G.iter_vertex (fun node -> - let v = find node in - G.iter_succ - (fun node' -> - let succ = find node' in - CallG.add_labeled_edge callg v Inter_functions succ; - let src_root = v.root in - let dst_root = succ.root in - if not (Vertex.equal src_root dst_root) then begin - CallG.add_labeled_edge callg src_root Inter_services dst_root - ( JS: no need of a `service_to_function' edge since - it is not possible to have an edge starting from a - not-a-root vertex and going to another service. - - no need of a `function_to_service' edge since the only - possible edges between two services go to a root. ) - end) - g - node) + let v = find node in + G.iter_succ + (fun node' -> + let succ = find node' in + CallG.add_labeled_edge callg v Inter_functions succ; + let src_root = v.root in + let dst_root = succ.root in + if not (Vertex.equal src_root dst_root) then begin + CallG.add_labeled_edge callg src_root Inter_services dst_root + ( JS: no need of a `service_to_function' edge since + it is not possible to have an edge starting from a + not-a-root vertex and going to another service. + + no need of a `function_to_service' edge since the only + possible edges between two services go to a root. ) + end) + g + node) g let compute g initial_roots = @@ -241,11 +243,7 @@ Vertices.clear (); callg - let entry_point () = match !entry_point_ref with - | None -> - Kernel.fatal "should call `Service_graph.compute' before calling \ -`Service_graph.entry_point'" - | Some s -> s + let entry_point () = !entry_point_ref ( *********************************************************************** ) ( Pretty-print ) @@ -263,11 +261,11 @@ let vertex_attributes s = let attr = - `Label + `Label (Pretty_utils.sfprintf "@[%a@]" !Ast_printer.d_ident - (G.V.name s.node)) - :: (`Color (Extlib.number_to_color (G.V.id s.root.node))) - :: G.V.attributes s.node + (G.V.name s.node)) + :: (`Color (Extlib.number_to_color (G.V.id s.root.node))) + :: G.V.attributes s.node in if s.is_root then `Shape `Diamond :: attr else attr @@ -285,9 +283,9 @@ Some { Graph.Graphviz.DotAttributes.sg_name = cs; sg_attributes = - [ `Label ("S " ^ cs); - `Color (Extlib.number_to_color id); - `Style `Bold ] } + [ `Label ("S " ^ cs); + `Color (Extlib.number_to_color id); + `Style `Bold ] } end @@ -299,9 +297,9 @@ module SS = Set.Make(struct - type t = G.V.t - let compare x y = Pervasives.compare (G.V.id x) (G.V.id y) - end) + type t = G.V.t + let compare x y = Pervasives.compare (G.V.id x) (G.V.id y) + end) type service_vertex = { service: int; mutable root: G.V.t; mutable nodes: SS.t } @@ -309,24 +307,24 @@ module SG = struct module M = Graph.Imperative.Digraph.ConcreteLabeled (struct - type t = service_vertex - let equal x y = x.service = y.service - let compare x y = Pervasives.compare x.service y.service - let hash x = x.service + type t = service_vertex + let equal x y = x.service = y.service + let compare x y = Pervasives.compare x.service y.service + let hash x = x.service end) (struct - type t = bool ref ( [true] for inter-service edge ) - let default = ref false - let compare = Pervasives.compare + type t = bool ref ( [true] for inter-service edge ) + let default = ref false + let compare = Pervasives.compare end) include M type tt = t module Datatype = Project.Datatype.Imperative - (struct - include M - let name = Project.Datatype.extend_name "Service_graph.SG " G.name - end) + (struct + include M + let name = Project.Datatype.extend_name "Service_graph.SG " G.name + end) end let get_service_id v = match v.mark with @@ -340,36 +338,36 @@ let id = get_service_id v in let node = v.node in try - let vertex = Hashtbl.find vertices id in - ( the service already exists ) - vertex.nodes <- SS.add node vertex.nodes; - if v.is_service then vertex.root <- node; - vertex + let vertex = Hashtbl.find vertices id in + ( the service already exists ) + vertex.nodes <- SS.add node vertex.nodes; + if v.is_service then vertex.root <- node; + vertex with Not_found -> - ( the service does not exist yet ) - let vertex = { service = id; root = node; nodes= SS.singleton node } in - SG.add_vertex sg vertex; - Hashtbl.add vertices id vertex; - vertex + ( the service does not exist yet ) + let vertex = { service = id; root = node; nodes= SS.singleton node } in + SG.add_vertex sg vertex; + Hashtbl.add vertices id vertex; + vertex in CallG.iter_edges (fun v1 v2 -> - let s1 = get_service v1 in - let s2 = get_service v2 in - match v1.is_service, v2.is_service with - | true, true -> - (try - let b = SG.E.label (SG.find_edge sg s1 s2) in - b := true - with Not_found -> - SG.add_edge sg s1 s2) - | true, false -> - assert false - | false, true -> - () - | false, false -> - if not (SG.mem_edge sg s1 s2 || SG.V.equal s1 s2) then - SG.add_edge sg s1 s2) + let s1 = get_service v1 in + let s2 = get_service v2 in + match v1.is_service, v2.is_service with + | true, true -> + (try + let b = SG.E.label (SG.find_edge sg s1 s2) in + b := true + with Not_found -> + SG.add_edge sg s1 s2) + | true, false -> + assert false + | false, true -> + () + | false, false -> + if not (SG.mem_edge sg s1 s2 || SG.V.equal s1 s2) then + SG.add_edge sg s1 s2) cg; sg diff -Nru frama-c-20110201+carbon+dfsg/src/misc/service_graph.mli frama-c-20111001+nitrogen+dfsg/src/misc/service_graph.mli --- frama-c-20110201+carbon+dfsg/src/misc/service_graph.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/service_graph.mli 2011-10-10 08:38:28.000000000 +0000 @@ -20,16 +20,21 @@ ( *) (************************************************************************) +( Compute services from a callgraph. *) + +(** Generic functor implementing the services algorithm according to a graph + implementation. *) module Make (G: sig type t module V: sig include Graph.Sig.HASHABLE val id: t -> int - (** assume is >= 0 and unique for each vertices of the graph *) + (** assume is >= 0 and unique for each vertices of the graph *) val name: t -> string val attributes: t -> Graph.Graphviz.DotAttributes.vertex list - val entry_point: unit -> t + val entry_point: unit -> t option + (** @modify Nitrogen-20111001 return an option*) end val iter_vertex : (V.t -> unit) -> t -> unit val iter_succ : (V.t -> unit) -> t -> V.t -> unit @@ -53,9 +58,10 @@ val compute: G.t -> Datatype.String.Set.t -> CallG.t val output_graph: out_channel -> CallG.t -> unit - val entry_point: unit -> CallG.V.t + val entry_point: unit -> CallG.V.t option (** [compute] must be called before - @since Carbon-20101201 ) + @since Carbon-20101201 + @modify Nitrogen-20111001 return an option type ) module TP: Graph.Graphviz.GraphWithDotAttrs with type t = CallG.t diff -Nru frama-c-20110201+carbon+dfsg/src/misc/subst.ml frama-c-20111001+nitrogen+dfsg/src/misc/subst.ml --- frama-c-20110201+carbon+dfsg/src/misc/subst.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/subst.ml 2011-10-10 08:38:28.000000000 +0000 @@ -40,15 +40,15 @@ inherit nopCilVisitor method vexpr e = match e.enode with | Lval((Var x, NoOffset)) -> - (try - let e = M.find x subst in - modified := true; - let e = if trans then expr e else e in - ChangeTo e - with Not_found -> - SkipChildren) + (try + let e = M.find x subst in + modified := true; + let e = if trans then expr e else e in + ChangeTo e + with Not_found -> + SkipChildren) | _ -> - DoChildren + DoChildren end in visitCilExpr visitor e diff -Nru frama-c-20110201+carbon+dfsg/src/misc/subst.mli frama-c-20111001+nitrogen+dfsg/src/misc/subst.mli --- frama-c-20110201+carbon+dfsg/src/misc/subst.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/misc/subst.mli 2011-10-10 08:38:28.000000000 +0000 @@ -40,7 +40,7 @@ val expr: ?trans:bool -> exp -> t -> exp * bool (** Apply the substitution to an expression. If [trans], the substitution is transitively applied. Default is [true]. - For example, with subst = \{ x -> &y; y -> b \} and exp = x, the result + For example, with subst = \{ x -> &y; y -> b \} and exp = x, the result is &b by default and &y if trans is false. The returned boolean flag is true is a substitution occured. ) diff -Nru frama-c-20110201+carbon+dfsg/src/occurrence/options.ml frama-c-20111001+nitrogen+dfsg/src/occurrence/options.ml --- frama-c-20110201+carbon+dfsg/src/occurrence/options.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/occurrence/options.ml 2011-10-10 08:38:27.000000000 +0000 @@ -32,7 +32,7 @@ (struct let option_name = "-occurrence" let help = "print results of occurrence analysis" - let kind = `Tuning + let kind = Parameter.Other end) ( diff -Nru frama-c-20110201+carbon+dfsg/src/occurrence/options.mli frama-c-20111001+nitrogen+dfsg/src/occurrence/options.mli --- frama-c-20110201+carbon+dfsg/src/occurrence/options.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/occurrence/options.mli 2011-10-10 08:38:27.000000000 +0000 @@ -22,7 +22,7 @@ include Plugin.S -module Print: Plugin.BOOL +module Print: Plugin.Bool (** @plugin development guide ) ( diff -Nru frama-c-20110201+carbon+dfsg/src/occurrence/register_gui.ml frama-c-20111001+nitrogen+dfsg/src/occurrence/register_gui.ml --- frama-c-20110201+carbon+dfsg/src/occurrence/register_gui.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/occurrence/register_gui.ml 2011-10-10 08:38:27.000000000 +0000 @@ -26,15 +26,21 @@ open Cil_types open Cil_datatype -module Enabled= - State_builder.Ref + +(* Show or hide the 'Occurrence' column of the gui filetree. ) +let show_column = ref (fun () -> ()) + +( Are results shown? ) +module Enabled = struct + include State_builder.Ref (Datatype.Bool) (struct - let name = "Occurrence_gui.Enabled" - let dependencies = [] - let kind = `Internal - let default () = true + let name = "Occrrence_gui.State" + let dependencies = [!Db.Occurrence.self] + let kind = `Internal + let default () = false end) +end let _ = Dynamic.register @@ -55,6 +61,7 @@ let find_occurrence (main_ui:Design.main_window_extension_points) vi () = ignore (!Db.Occurrence.get vi); Enabled.set true; + !show_column (); main_ui#rehighlight () ( Only these localizable interest this plugin ) @@ -73,23 +80,23 @@ () | Some (result, vi) -> let highlight () = - let tag = make_tag buffer "occurrence" [`BACKGROUND "yellow" ] in + let tag = make_tag buffer "occurrence" [`BACKGROUND "yellow" ] in apply_tag buffer tag start stop in match loc with | PLval (_, ki, lval) -> - let same_lval (k, l) = Kinstr.equal k ki && Lval.equal l lval in - if List.exists same_lval result then highlight () + let same_lval (k, l) = Kinstr.equal k ki && Lval.equal l lval in + if List.exists same_lval result then highlight () | PTermLval (_,ki,term_lval) -> - let same_tlval (k, l) = + let same_tlval (k, l) = Logic_utils.is_same_tlval - (Logic_utils.lval_to_term_lval ~cast:true l) - term_lval - && Kinstr.equal k ki - in - if List.exists same_tlval result then highlight () + (Logic_utils.lval_to_term_lval ~cast:true l) + term_lval + && Kinstr.equal k ki + in + if List.exists same_tlval result then highlight () | PVDecl(_, vi') when Varinfo.equal vi vi' -> - highlight () + highlight () | PVDecl _ | PStmt _ | PGlobal _ | PIP _ -> () module FollowFocus = @@ -125,7 +132,7 @@ localizable in ignore (set_selected#connect#pressed - (fun () -> Design.apply_on_selected do_select)); + (fun () -> History.apply_on_selected do_select)); ( check_button enabled ) let enabled = Enabled.get () in let enabled_button = GButton.check_button @@ -139,6 +146,7 @@ ~callback: (fun () -> Enabled.set enabled_button#active; + !show_column (); main_ui#rehighlight ())); ( check_button followFocus ) let followFocus = GButton.check_button @@ -154,18 +162,21 @@ let old_vi = ref (-2) in fun () -> (let sensitive_set_selected_button = ref false in - Design.apply_on_selected + History.apply_on_selected (apply_on_vi (fun _ -> sensitive_set_selected_button:=true)); set_selected#misc#set_sensitive !sensitive_set_selected_button; - enabled_button#set_active (Enabled.get()); + if Enabled.get () <> enabled_button#active then ( + enabled_button#set_active (Enabled.get ()); + !show_column (); + ); let new_result = !Db.Occurrence.get_last_result () in (match new_result with - | None when !old_vi<> -1 -> + | None when !old_vi<> -1 -> old_vi := -1; e#set_label "None" - | Some (_,vi) when vi.vid<> !old_vi-> + | Some (_,vi) when vi.vid<> !old_vi-> old_vi := vi.vid; e#set_label vi.vname - | _ -> ())) + | _ -> ())) in "Occurrence",w#coerce,Some refresh @@ -177,38 +188,42 @@ let callback = find_occurrence main_ui vi in ignore (popup_factory#add_item "_Occurrence" ~callback); if FollowFocus.get () then - ignore (Glib.Idle.add (fun () -> callback (); false)) + ignore (Glib.Idle.add (fun () -> callback (); false)) end) localizable let file_tree_decorate (file_tree:Filetree.t) = - file_tree#append_pixbuf_column - "Occurrence" - (fun globs -> - match !Db.Occurrence.get_last_result () with - | None -> ( occurrence not computed ) - [`STOCK_ID ""] - | Some (result, _) -> - let in_globals (ki,_) = - match ki with - | Kglobal -> false - | Kstmt stmt -> - let kf = Kernel_function.find_englobing_kf stmt in - let {vid=v0} = Kernel_function.get_vi kf in - List.exists - (fun glob -> match glob with - | GFun ({svar ={vid=v1}},_ ) -> v1=v0 - | _ -> false) - globs - in - if List.exists in_globals result then [`STOCK_ID "gtk-apply"] - else [`STOCK_ID ""]) + show_column := + file_tree#append_pixbuf_column + ~title:"Occurrence" + (fun globs -> + match !Db.Occurrence.get_last_result () with + | None -> ( occurrence not computed ) + [`STOCK_ID ""] + | Some (result, _) -> + let in_globals (ki,_) = + match ki with + | Kglobal -> false + | Kstmt stmt -> + let kf = Kernel_function.find_englobing_kf stmt in + let {vid=v0} = Kernel_function.get_vi kf in + List.exists + (fun glob -> match glob with + | GFun ({svar ={vid=v1}},_ ) -> v1=v0 + | _ -> false) + globs + in + if List.exists in_globals result then [`STOCK_ID "gtk-apply"] + else [`STOCK_ID ""]) + (fun () -> Enabled.get ()); + !show_column () let main main_ui = main_ui#register_source_selector occurrence_selector; main_ui#register_source_highlighter occurrence_highlighter; main_ui#register_panel occurrence_panel; - file_tree_decorate main_ui#file_tree + file_tree_decorate main_ui#file_tree; +;; let () = Design.register_extension main diff -Nru frama-c-20110201+carbon+dfsg/src/occurrence/register.ml frama-c-20111001+nitrogen+dfsg/src/occurrence/register.ml --- frama-c-20110201+carbon+dfsg/src/occurrence/register.ml 2011-02-07 13:53:54.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/occurrence/register.ml 2011-10-10 08:38:27.000000000 +0000 @@ -37,9 +37,9 @@ Cil_state_builder.Varinfo_hashtbl (Datatype.Pair(Kinstr)(Lval)) (struct - let size = 17 - let name = "Occurrences.State" - let dependencies = [ Db.Value.self ] + let size = 17 + let name = "Occurrences.State" + let dependencies = [ Db.Value.self ] let kind = `Internal end) @@ -47,8 +47,8 @@ State_builder.Option_ref (Varinfo) (struct - let name = "Occurrences.LastResult" - let dependencies = [ Ast.self; IState.self ] + let name = "Occurrences.LastResult" + let dependencies = [ Ast.self; IState.self ] let kind = `Internal end) @@ -74,16 +74,16 @@ let iter f = let old, l = IState.fold - (fun v elt (old, l) -> match v, old with - | v, None -> - assert (l = []); - Some v, [ elt ] - | v, (Some old as some) when Varinfo.equal v old -> - some, elt :: l - | v, Some old -> - f old l; - Some v, [ elt ]) - (None, []) + (fun v elt (old, l) -> match v, old with + | v, None -> + assert (l = []); + Some v, [ elt ] + | v, (Some old as some) when Varinfo.equal v old -> + some, elt :: l + | v, Some old -> + f old l; + Some v, [ elt ]) + (None, []) in Extlib.may (fun v -> f v l) old @@ -105,8 +105,8 @@ let ki = self#current_ki in if Db.Value.is_accessible ki then begin let z = - !Db.Value.lval_to_zone - ki ~with_alarms:CilE.warn_none_mode (Var vi, NoOffset) + !Db.Value.lval_to_zone + ki ~with_alarms:CilE.warn_none_mode (Var vi, NoOffset) in decls <- (vi, z) :: decls end; @@ -119,7 +119,7 @@ if not (Locations.Zone.equal Locations.Zone.bottom z) then List.iter (fun (vi, zvi) -> - if Locations.Zone.intersects z zvi then Occurrences.add vi ki lv) + if Locations.Zone.intersects z zvi then Occurrences.add vi ki lv) decls end; DoChildren @@ -129,7 +129,7 @@ let lv = !Db.Properties.Interp.term_lval_to_lval ~result:None tlv in ignore (self#vlval lv) with Invalid_argument msg -> - error "%s@." msg); + error ~current:true "%s@." msg); DoChildren method vstmt_aux s = @@ -157,7 +157,17 @@ | Kstmt s -> Format.fprintf fmt "%d" s.sid let print_one fmt v l = - Format.fprintf fmt "variable %s (%d):@\n" v.vname v.vid; + Format.fprintf fmt "variable %s (%s):@\n" + v.vname + (if v.vglob then "global" + else + let kf_name = match l with + | [] | (Kglobal, _) :: _ -> assert false + | (Kstmt s, _) :: _ -> + Kernel_function.get_name (Kernel_function.find_englobing_kf s) + in + if v.vformal then "parameter of " ^ kf_name + else "local of " ^ kf_name); List.iter (fun (ki, lv) -> Format.fprintf fmt " sid %a: %a@\n" d_ki ki d_lval lv) l @@ -173,8 +183,13 @@ Db.register (Db.Journalize ("Occurrence.get", - Datatype.func - Varinfo.ty (Datatype.list (Datatype.pair Kinstr.ty Lval.ty)))) + Datatype.func + Varinfo.ty + ( [JS 2011/04/01] Datatype.list buggy in presence of journalisation. + See comment in datatype.ml ) + ((Datatype.list (Datatype.pair Kinstr.ty Lval.ty))) + (let module L = Datatype.List(Datatype.Pair(Kinstr)(Lval)) in + L.ty))) Db.Occurrence.get get; Db.register diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/annot.ml frama-c-20111001+nitrogen+dfsg/src/pdg/annot.ml --- frama-c-20110201+carbon+dfsg/src/pdg/annot.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/annot.ml 2011-10-10 08:38:30.000000000 +0000 @@ -25,18 +25,15 @@ open Cil_types open Cil_datatype -module M = Macros -module G = PdgTypes.G -module Dpd = PdgTypes.Dpd -module FI = PdgIndex.FctIndex -module Key = PdgIndex.Key +open PdgTypes +open PdgIndex -type data_info = ((PdgTypes.Node.t Locations.Zone.t option) list +type data_info = ((Node.t * Locations.Zone.t option) list * Locations.Zone.t option) option -type ctrl_info = PdgTypes.Node.t list +type ctrl_info = Node.t list -type decl_info = PdgTypes.Node.t list +type decl_info = Node.t list let zone_info_nodes pdg data_info = let add_info_nodes pdg (nodes_acc, undef_acc) info = @@ -47,7 +44,7 @@ Locations.Zone.pretty zone (if before then "before" else "after") stmt.sid; let nodes, undef_loc = - Sets.find_location_nodes_at_stmt pdg stmt before zone + Sets.find_location_nodes_at_stmt pdg stmt ~before zone in let undef_acc = match undef_acc, undef_loc with | None, _ -> undef_loc @@ -71,13 +68,13 @@ Varinfo.Set.fold add_decl_nodes decl_info [] let find_nodes_for_function_contract pdg f_interpret = - let kf = M.get_pdg_kf pdg in + let kf = Pdg.get_kf pdg in let (data_info, decl_info) = f_interpret kf in let data_dpds = zone_info_nodes pdg data_info in let decl_nodes = get_decl_nodes pdg decl_info in decl_nodes, data_dpds -let find_fun_precond_nodes (pdg:PdgTypes.Pdg.t) p = +let find_fun_precond_nodes (pdg:Pdg.t) p = let named_p = { name = []; loc = Location.unknown; content = p } in let f_interpret kf = let f_ctx = !Db.Properties.Interp.To_zone.mk_ctx_func_contrat @@ -92,13 +89,13 @@ ~state_opt:(Some false) kf in !Db.Properties.Interp.To_zone.from_pred named_p f_ctx in let nodes,deps = find_nodes_for_function_contract pdg f_interpret - in let nodes = - (* find is \result is used in p, and if it is the case, - * add the node [Sets.find_output_node pdg] + in let nodes = + (* find is \result is used in p, and if it is the case, + * add the node [Sets.find_output_node pdg] * to the returned list of nodes. ) if !Db.Properties.Interp.to_result_from_pred named_p then - (Sets.find_output_node pdg)::nodes + (Sets.find_output_node pdg)::nodes else nodes in nodes,deps @@ -109,17 +106,16 @@ !Db.Properties.Interp.To_zone.from_term t f_ctx in find_nodes_for_function_contract pdg f_interpret -let find_code_annot_nodes pdg ~before stmt annot = - Pdg_parameters.debug "[pdg:annotation] CodeAnnot-%d %s stmt %d : %a @." - annot.annot_id - (if before then "before" else "after") stmt.sid +let find_code_annot_nodes pdg stmt annot = + Pdg_parameters.debug "[pdg:annotation] CodeAnnot-%d stmt %d : %a @." + annot.annot_id stmt.sid !Ast_printer.d_code_annotation annot; - if Db.Value.is_accessible (Cil_types.Kstmt stmt) then + if Db.Value.is_reachable_stmt stmt then try begin - let kf = M.get_pdg_kf pdg in + let kf = Pdg.get_kf pdg in let (data_info, decl_info), pragmas = - !Db.Properties.Interp.To_zone.from_stmt_annot annot ~before (stmt, kf) + !Db.Properties.Interp.To_zone.from_stmt_annot annot (stmt, kf) in let data_dpds = zone_info_nodes pdg data_info in let decl_nodes = get_decl_nodes pdg decl_info in @@ -138,15 +134,15 @@ let ctrl_dpds = Stmt.Set.fold add_stmt_nodes stmt_pragmas ctrl_dpds in if Pdg_parameters.debug_atleast 2 then begin let p fmt (n,z) = match z with - | None -> PdgTypes.Node.pretty fmt n + | None -> Node.pretty fmt n | Some z -> Format.fprintf fmt "%a(%a)" - PdgTypes.Node.pretty n Locations.Zone.pretty z + Node.pretty n Locations.Zone.pretty z in let pl fmt l = List.iter (fun n -> Format.fprintf fmt " %a" p n) l in Pdg_parameters.debug " ctrl nodes = %a" - PdgTypes.Node.pretty_list ctrl_dpds; + Node.pretty_list ctrl_dpds; Pdg_parameters.debug " decl nodes = %a" - PdgTypes.Node.pretty_list decl_nodes; + Node.pretty_list decl_nodes; match data_dpds with | None -> Pdg_parameters.debug " data nodes = None (failed to compute)" @@ -169,7 +165,7 @@ Pdg_parameters.debug ~level:2 "[pdg:annotation] CodeAnnot-%d : unreachable stmt ! @." annot.annot_id; - raise PdgIndex.NotFound ( unreachable statement ) + raise Not_found ( unreachable statement ) end ( diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/annot.mli frama-c-20111001+nitrogen+dfsg/src/pdg/annot.mli --- frama-c-20110201+carbon+dfsg/src/pdg/annot.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/annot.mli 2011-10-10 08:38:30.000000000 +0000 @@ -45,8 +45,7 @@ (** @raise Not_found when the statement is unreachable. ) val find_code_annot_nodes : - PdgTypes.Pdg.t -> - before:bool -> Cil_types.stmt -> Cil_types.code_annotation -> + PdgTypes.Pdg.t -> Cil_types.stmt -> Cil_types.code_annotation -> ctrl_info decl_info * data_info val find_fun_precond_nodes : PdgTypes.Pdg.t -> Cil_types.predicate -> diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/build.ml frama-c-20111001+nitrogen+dfsg/src/pdg/build.ml --- frama-c-20110201+carbon+dfsg/src/pdg/build.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/build.ml 2011-10-10 08:38:30.000000000 +0000 @@ -33,12 +33,14 @@ {!module: Build.Computer} below). *) +let dkey = "build" +let debug fmt = Pdg_parameters.debug ~dkey fmt +let debug2 fmt = Pdg_parameters.debug ~dkey fmt ~level:2 + open Cil_types module IH = Inthash open Cil_datatype -module M = Macros -module P = Pdg_parameters module G = PdgTypes.G module Dpd = PdgTypes.Dpd module FI = PdgIndex.FctIndex @@ -48,24 +50,30 @@ exception Err_Bot of string (** set of nodes of the graph ) -module SimpleNodeSet = Set.Make(PdgTypes.Node) +module BoolNodeSet = Set.Make(Datatype.Pair(Datatype.Bool)(PdgTypes.Node)) ( for mk_list_zones see Locations.Zone.fold_enum_by_base *) +let pretty_node ?(key=false) fmt n = + PdgTypes.Node.pretty fmt n; + if key then + Format.fprintf fmt ": %a" PdgIndex.Key.pretty (PdgTypes.Node.elem_key n) + let is_variadic kf = let varf = Kernel_function.get_vi kf in match varf.vtype with - TFun (_, _, is_variadic, _) -> is_variadic - | _ -> (Macros.bug - "The variable of a kernel_function has to be a function !") - + | TFun (_, _, is_variadic, _) -> is_variadic + | _ -> Pdg_parameters.fatal + "The variable of a kernel_function has to be a function !" (** add a dependency with the given label between the two nodes. Pre : the nodes have to be already in pdg. ) let add_dpd_in_g graph v1 dpd_kind part_opt v2 = ( let part_opt = match part_opt with Some _ | None -> None in *) - P.debug "add_dpd : %a -> %a@." Macros.pretty_node v1 Macros.pretty_node v2; + debug "add_dpd : %a -%a-> %a@." + PdgTypes.Node.pretty v1 Dpd.pretty_td dpd_kind + PdgTypes.Node.pretty v2; G.add_dpd graph v1 dpd_kind part_opt v2 (** Module to build the PDG. *) @@ -74,9 +82,9 @@ type t (** create an empty pdg for the function*) - val create : Db_types.kernel_function -> t + val create : kernel_function -> t - val get_kf : t -> Db_types.kernel_function + val get_kf : t -> kernel_function val pretty : Format.formatter -> t -> unit @@ -89,6 +97,8 @@ val print_state : Format.formatter -> t_state -> unit + val empty_state : t_state + (** type to describe the data locations (to store information in [t_state]) *) type t_loc = Locations.Zone.t @@ -114,7 +124,14 @@ (** for skip statement : we want to add a node in the PDG in ordrer to be able * to store information (like marks) about this statement later on *) - val process_skip : t -> Cil_types.stmt -> unit + val process_skip : t -> t_state -> Cil_types.stmt -> t_state option + + (** similar to [process_skip] but returns an empty state (bottom)*) + val process_unreachable : t -> t_state -> Cil_types.stmt -> t_state option + + (** similar to [process_unreachable] but for call stmt *) + val process_unreachable_call : + t -> t_state -> Cil_types.stmt -> t_state option (** Add a node for the stmt which is a jump. Add control dependencies from this node @@ -123,7 +140,8 @@ Don't use for jumps with data dependencies : use [process_jump_with_exp] instead ! ) - val process_jump : t -> Cil_types.stmt -> Cil_types.stmt list -> unit + val process_jump : t -> Cil_types.stmt -> + bool Cil_datatype.Stmt.Hptset.t -> unit val process_block : t -> Cil_types.stmt -> Cil_types.block -> unit @@ -134,11 +152,11 @@ For conditional jumps and returns. ) val process_jump_with_exp : - t -> Cil_types.stmt -> Cil_types.stmt list -> + t -> Cil_types.stmt -> (bool Cil_datatype.Stmt.Hptset.t) -> t_state -> t_loc -> Varinfo.Set.t -> unit - ( Kind of 'join' of hte two states + ( Kind of 'join' of the two states * but test before if the new state is included in ~old. * @return (true, old U new) if the result is a new state, * (false, old) if new is included in old. @@ -151,9 +169,9 @@ val process_call_args : t -> t_state -> Cil_types.stmt -> (t_loc * Varinfo.Set.t) list -> - (int * t_arg_nodes) + (t_arg_nodes) val process_call_params : t -> t_state -> Cil_types.stmt -> - Db_types.kernel_function -> t_arg_nodes -> + kernel_function -> t_arg_nodes -> t_state val process_call_ouput : t -> t_state -> t_state -> Cil_types.stmt -> @@ -190,15 +208,15 @@ (** The PDG used during its computation. ) - type t = { fct : Db_types.kernel_function; + type t = { fct : kernel_function; mutable topinput : PdgTypes.Node.t option; mutable other_inputs : (PdgTypes.Node.t Dpd.td * Locations.Zone.t) list; graph : G.t; states : Pdg_state.t_states; - index : PdgTypes.Pdg.t_index; + index : PdgTypes.Pdg.t_fi; - ctrl_dpds : SimpleNodeSet.t Kinstr.Hashtbl.t ; + ctrl_dpds : BoolNodeSet.t Stmt.Hashtbl.t ; (** The nodes to which each stmt control-depend on. * The links will be added in the graph at the end. ) decl_nodes : t_node Varinfo.Hashtbl.t ; @@ -206,20 +224,19 @@ to build the dependencies. ) } + let empty_state = Pdg_state.empty + let create kf = let nb_stmts = - try - let fundec = Kernel_function.get_definition kf in - List.length fundec.sallstmts - with Kernel_function.No_Definition -> - 42 + if !Db.Value.use_spec_instead_of_definition kf then 17 + else List.length (Kernel_function.get_definition kf).sallstmts in let index = FI.create nb_stmts in let states = IH.create nb_stmts in let graph = G.create () in { fct = kf; graph = graph; states = states; index = index; topinput = None; other_inputs = []; - ctrl_dpds = Kinstr.Hashtbl.create nb_stmts ; + ctrl_dpds = Stmt.Hashtbl.create nb_stmts ; decl_nodes = Varinfo.Hashtbl.create 10 ; } @@ -240,7 +257,7 @@ let add_elem pdg key = let add_new_node key = let new_node = G.add_elem (graph pdg) key in - P.debug "add_new_node %a @." PdgTypes.Node.pretty new_node; + debug "add_new_node %a@." (pretty_node ~key:true) new_node; new_node in let index = nodes_index pdg in @@ -249,7 +266,7 @@ | Key.CallStmt _ -> assert false (FI.find_info_call index (Key.call_from_id call_id)) | _ -> FI.find_info index key - with PdgIndex.NotFound -> + with Not_found -> let new_node = add_new_node key in let _ = match key with | Key.CallStmt _call_id -> assert false @@ -263,15 +280,13 @@ let topinput pdg = match pdg.topinput with | None -> - let key = Key.top_input in - let topinput = add_elem pdg key in + let topinput = add_elem pdg Key.top_input in pdg.topinput <- Some topinput; topinput | Some top -> top let decl_var pdg var = - let key = Key.decl_var_key var in - let new_node = add_elem pdg key in + let new_node = add_elem pdg (Key.decl_var_key var) in Varinfo.Hashtbl.add pdg.decl_nodes var new_node; new_node @@ -302,7 +317,7 @@ let var_decl_node = Varinfo.Hashtbl.find pdg.decl_nodes var in add_decl_dpd pdg node dpd_kind var_decl_node with Not_found -> - () + () in Varinfo.Set.iter add_dpd varset @@ -325,38 +340,63 @@ match undef_zone with None -> () | Some undef_zone -> add_to_inputs pdg n dpd_kind undef_zone + (** Process and clear [pdg.ctrl_dpds] which contains a mapping between the * statements and the control dependencies that have to be added to the - * statement nodes. ) + statement nodes. + * Because some jump nodes can vanish due to optimisations using the value + * analysis, we can not rely on the transitivity of the dependencies. + * So let's compute a transitive closure of the control dependencies. + * The table gives : stmt -> ctrl dependency nodes of the statement. + * So for each stmt, we have to find if some of its ctrl nodes + * also have dependencies that have to be added to the stmt. + * ) let add_ctrl_dpds pdg = - let add_node_ctrl_dpd n ctrl_node = add_ctrl_dpd pdg n ctrl_node in - let add_node_ctrl_dpds n ctrl_node_set = - SimpleNodeSet.iter (add_node_ctrl_dpd n) ctrl_node_set in - let add_stmt_ctrl_dpd ki ctrl_node_set = + let add_indirect ctrl_node_set = + ( Also add the ctrl_node dependencies to the set. + * TODOopt: probably a better way to do that if it happens to work ! ) + let rec add_node (real, n) (acc, seen) = + if BoolNodeSet.mem (real, n) seen then (acc, seen) + else + let seen = BoolNodeSet.add (real, n) seen in + let acc = if real then BoolNodeSet.add (true, n) acc else acc in + add_rec n (acc, seen) + and add_rec ctrl_node acc = + match PdgTypes.Node.elem_key ctrl_node with + | Key.Stmt ctrl_stmt -> + (try + let stmt_dpds = Stmt.Hashtbl.find pdg.ctrl_dpds ctrl_stmt in + BoolNodeSet.fold add_node stmt_dpds acc + with Not_found -> acc) + | _ -> ( strange control dependency ! Ignore. ) acc + in + let acc = BoolNodeSet.empty, BoolNodeSet.empty in + let acc, _ = BoolNodeSet.fold add_node ctrl_node_set acc in + acc + in + let add_stmt_ctrl_dpd stmt ctrl_node_set = let index = nodes_index pdg in - let label_nodes stmt labels label = - try labels @ FI.find_all index (Key.label_key stmt label) - with PdgIndex.NotFound -> labels + let stmt_nodes = + try FI.find_all index (Key.stmt_key stmt) + with Not_found -> [] + ( some stmts have no node if they are dead code for instance) + in + let label_nodes acc label = + try acc @ FI.find_all index (Key.label_key stmt label) + with Not_found -> acc in - match ki with - | Kstmt stmt -> - let lab_nodes = - List.fold_left (label_nodes stmt) [] stmt.labels - in - let stmt_nodes = - try FI.find_all index (Key.stmt_key stmt) - with PdgIndex.NotFound -> [] - ( some stmts have no node if they are dead code for - * instance) - in - let nodes = lab_nodes @ stmt_nodes in - List.iter (fun n -> add_node_ctrl_dpds n ctrl_node_set) nodes - | _ -> assert false + let stmt_nodes = List.fold_left label_nodes stmt_nodes stmt.labels in + let ctrl_node_set = add_indirect ctrl_node_set in + let add_node_ctrl_dpds stmt_node = + BoolNodeSet.iter + (fun (_, n) -> add_ctrl_dpd pdg stmt_node n) ctrl_node_set + in List.iter add_node_ctrl_dpds stmt_nodes in - Kinstr.Hashtbl.iter add_stmt_ctrl_dpd pdg.ctrl_dpds; - Kinstr.Hashtbl.clear pdg.ctrl_dpds + Stmt.Hashtbl.iter add_stmt_ctrl_dpd pdg.ctrl_dpds; + Stmt.Hashtbl.clear pdg.ctrl_dpds let test_and_merge_states = Pdg_state.test_and_merge + let print_state = Pdg_state.pretty let process_declarations pdg ~formals ~locals = @@ -374,8 +414,7 @@ ) let do_param (n, state) v = let decl_node = decl_var pdg v in - let key = Key.param_key n v in - let new_node = add_elem pdg key in + let new_node = add_elem pdg (Key.param_key n) in add_decl_dpd pdg new_node Dpd.Addr decl_node ; add_decl_dpd pdg decl_node Dpd.Addr new_node ; let new_state = @@ -385,31 +424,24 @@ in let _next_in_num, new_state = List.fold_left do_param (1, empty_state) formals in - (* set_max_in pdg (next_in_num - 1); ) - - ( local variables *) List.iter (fun v -> ignore (decl_var pdg v)) locals; - new_state let process_call_node pdg call_stmt = - let key = Key.call_ctrl_key call_stmt in - let _new_node = add_elem pdg key in () + ignore (add_elem pdg (Key.call_ctrl_key call_stmt)) let ctrl_call_node pdg call_stmt = try FI.find_info (nodes_index pdg) (Key.call_ctrl_key call_stmt) - with PdgIndex.NotFound -> assert false + with Not_found -> assert false let process_call_args pdg d_state stmt args_dpds = let num = ref 1 in let process_arg (dpds, decl_dpds) = - let key = Key.call_input_key stmt !num in - let new_node = add_elem pdg key in + let new_node = add_elem pdg (Key.call_input_key stmt !num) in let _ = add_dpds pdg new_node Dpd.Data d_state dpds in let _ = add_decl_dpds pdg new_node Dpd.Data decl_dpds in - num := !num+1; new_node - in let arg_nodes = List.map process_arg args_dpds in - !num, arg_nodes + incr num; new_node + in List.map process_arg args_dpds (** Add a PDG node for each formal argument, * and add its dependencies to the corresponding argument node. @@ -432,7 +464,8 @@ | [], _ -> (* call to a variadic function ) ( warning already sent during 'from' computation. ) state - | _, [] -> Macros.bug "call to a function with to few arguments" + | _, [] -> Pdg_parameters.fatal + "call to a function with to few arguments" in do_param_arg d_state param_list arg_nodes let create_call_output_node pdg state stmt out_key out_from fct_dpds = @@ -452,8 +485,7 @@ (new_node, new_state) let add_from pdg state_before state lval (default, deps) = - let key = Key.out_from_key lval in - let new_node = add_elem pdg key in + let new_node = add_elem pdg (Key.out_from_key lval) in let exact = (not default) in let state = Pdg_state.add_loc_node state exact lval new_node in let _ = add_dpds pdg new_node Dpd.Data state_before deps in @@ -465,7 +497,7 @@ ( TODO : Check this with Pascal ! * (Locations.Zone.cardinal_zero_or_one out) && ) (not default) in - P.debug "call-%d Out%d : %a From %a (%sexact)@." + debug "call-%d Out%d : %a From %a (%sexact)@." stmt.sid numout Locations.Zone.pretty out Locations.Zone.pretty from_out (if exact then "" else "not "); @@ -485,10 +517,10 @@ in let _ = add_dpds pdg new_node Dpd.Addr state_before_call l_dpds in let _ = add_decl_dpds pdg new_node Dpd.Addr l_decl in - let new_state = Pdg_state.add_loc_node state_before_call exact l_loc new_node in + let new_state = + Pdg_state.add_loc_node state_before_call exact l_loc new_node in new_state - let process_asgn pdg d_state stmt ~l_loc ~exact ~l_dpds ~l_decl ~r_dpds ~r_decl = let key = Key.stmt_key stmt in @@ -498,15 +530,22 @@ let _ = add_decl_dpds pdg new_node Dpd.Data r_decl in new_state - let process_skip pdg stmt = - let key = Key.stmt_key stmt in - let _new_node = add_elem pdg key in - () - + let process_skip pdg _state stmt = + let _new_node = add_elem pdg (Key.stmt_key stmt) in + None ( keep previous state ) + + let process_unreachable _pdg _state _stmt = + ( let key = Key.stmt_key stmt in + let _new_node = add_elem pdg key in ) + Some Pdg_state.empty + + let process_unreachable_call _pdg _state _call_stmt = + ( let key = Key.call_ctrl_key call_stmt in + let _new_node = add_elem pdg key in ) + Some Pdg_state.empty let add_label pdg label label_stmt jump_node = - let key = Key.label_key label_stmt label in - let label_node = add_elem pdg key in + let label_node = add_elem pdg (Key.label_key label_stmt label) in add_ctrl_dpd pdg jump_node label_node let add_dpd_goto_label pdg goto_node dest_goto = @@ -515,9 +554,15 @@ | Label _ as lab :: _ -> Some lab | _ :: rest -> pickLabel rest in - match pickLabel dest_goto.labels with - | Some label -> add_label pdg label dest_goto goto_node - | None -> assert false ( goto sans label ??? ) + let label = match pickLabel dest_goto.labels with + | Some label -> label + | None -> + ( break and continue might not jump to a stmt with label : create one) + let lname = Printf.sprintf "fc_stmt_%d" dest_goto.sid in + let label = Label (lname, Cil_datatype.Stmt.loc dest_goto, false) in + dest_goto.labels <- label::dest_goto.labels; + label + in add_label pdg label dest_goto goto_node let add_dpd_switch_cases pdg switch_node case_stmts = let add_case stmt = @@ -532,29 +577,33 @@ | None -> assert false ( switch sans case ou default ??? ) in List.iter add_case case_stmts - ( The control dependencies are stored : they will be added at the end + (** The control dependencies are stored : they will be added at the end by [finalize_pdg] ) - let store_ctrl_dpds pdg node controled_stmt = + let store_ctrl_dpds pdg node iterator (real_dpd, controled_stmt) = + debug2 "store_ctrl_dpds on %a (real = %b)@." + (pretty_node ~key:true) node real_dpd ; let add_ctrl_dpd stmt = - let kinstr = (Kstmt stmt) in let new_dpds = try - let old_dpds = Kinstr.Hashtbl.find pdg.ctrl_dpds kinstr in - SimpleNodeSet.add node old_dpds - with Not_found -> SimpleNodeSet.singleton node + let old_dpds = Stmt.Hashtbl.find pdg.ctrl_dpds stmt in + BoolNodeSet.add (real_dpd, node) old_dpds + with Not_found -> BoolNodeSet.singleton (real_dpd, node) in - Kinstr.Hashtbl.replace pdg.ctrl_dpds kinstr new_dpds - in List.iter add_ctrl_dpd controled_stmt + Stmt.Hashtbl.replace pdg.ctrl_dpds stmt new_dpds + in iterator add_ctrl_dpd controled_stmt let mk_jump_node pdg stmt controled_stmts = - let key = Key.stmt_key stmt in - let new_node = add_elem pdg key in + let new_node = add_elem pdg (Key.stmt_key stmt) in let _ = match stmt.skind with - | If _ | Continue _ | Break _ | Loop _ | Return _ -> () - | Switch (_,_,stmts,_) -> add_dpd_switch_cases pdg new_node stmts + | If _ | Loop _ | Return _ -> () + | Break _ | Continue _ -> + ( can use : add_dpd_goto_label pdg new_node s + * if we want later to change break and continue to goto... + ) () | Goto (sref,_) -> add_dpd_goto_label pdg new_node !sref + | Switch (_,_,stmts,_) -> add_dpd_switch_cases pdg new_node stmts | _ -> assert false - in store_ctrl_dpds pdg new_node controled_stmts; + in store_ctrl_dpds pdg new_node Stmt.Hptset.iter controled_stmts; new_node let process_jump pdg stmt controled_stmts = @@ -567,19 +616,16 @@ let add_blk_ctrl_dpds pdg key bstmts = let new_node = add_elem pdg key in - store_ctrl_dpds pdg new_node bstmts + store_ctrl_dpds pdg new_node List.iter (true, bstmts) let process_block pdg stmt blk = - let key = Key.stmt_key stmt in - add_blk_ctrl_dpds pdg key blk.bstmts + add_blk_ctrl_dpds pdg (Key.stmt_key stmt) blk.bstmts let process_entry_point pdg bstmts = - let key = Key.entry_point in - add_blk_ctrl_dpds pdg key bstmts + add_blk_ctrl_dpds pdg Key.entry_point bstmts let create_fun_output_node pdg state dpds = - let key = Key.output_key in - let new_node = add_elem pdg key in + let new_node = add_elem pdg Key.output_key in match state with | Some state -> add_dpds pdg new_node Dpd.Data state dpds | None -> ( return is unreachable ) () @@ -588,7 +634,10 @@ let key_return = Key.stmt_key ret_stmt in let return_node = add_elem pdg key_return in let retres_loc = Db.Value.find_return_loc (get_kf pdg) in - let retres = Locations.valid_enumerate_bits retres_loc in + let retres = + Locations.valid_enumerate_bits ~for_writing:false + retres_loc + in let _ = add_dpds pdg return_node Dpd.Data state retres_loc_dpds in let _ = add_decl_dpds pdg return_node Dpd.Data retres_decls in let new_state = Pdg_state.add_loc_node state true retres return_node in @@ -607,14 +656,14 @@ (notice that now, they can overlap, for example we can have G and G.a) * And also deals with warning for uninitialized local variables. ) let process_other_inputs pdg = - P.debug ~level:2 "process_other_inputs@."; + debug2 "process_other_inputs@."; let rec add n dpd_kind (state, zones) z_or_top = ( be careful because [z] can intersect several elements in [zones] *) match zones with | [] -> let key = Key.implicit_in_key z_or_top in let nz = add_elem pdg key in - P.debug "add_implicit_input : %a@." + debug "add_implicit_input : %a@." Locations.Zone.pretty z_or_top ; let state = Pdg_state.add_init_state_input state z_or_top nz in let _ = add_z_dpd pdg n dpd_kind None nz in @@ -644,12 +693,10 @@ let do_z z acc = add n dpd_kind acc z in Locations.Zone.fold_enum_by_base do_z z acc in acc - else - begin - Cil.log "[pdg warning] might use uninitialized : %a" - Locations.Zone.pretty z ; - acc - end + else begin + debug2 "might use uninitialized : %a" Locations.Zone.pretty z; + acc + end in let (state, _) = List.fold_left add_zone (Pdg_state.empty, []) pdg.other_inputs @@ -657,94 +704,87 @@ (** @param from_opt for undefined functions (declarations) ) let finalize_pdg pdg from_opt = - P.debug ~level:2 "try to finalize_pdg"; + debug2 "try to finalize_pdg"; let last_state = try Some (Pdg_state.get_last_state (get_states pdg)) with Not_found -> - CilE.warn_once "no final state. Probably unreachable..."; None - in - let _ = match from_opt with - | None -> () ( defined function : retres already processed. ) - | Some froms -> ( undefined function : add output 0 ) - ( TODO : also add the nodes for the other from ! ) - let in_state = - match last_state with Some s -> s | None -> assert false in - let state = in_state in - let process_out out (default, from_out) state = - add_from pdg in_state state out (default, from_out) - in - let from_table = froms.Function_Froms.deps_table in - let new_state = - try Lmap_bitwise.From_Model.fold process_out from_table state - with Lmap_bitwise.From_Model.Cannot_fold -> ( TOP in from_table ) - process_out Locations.Zone.top (false, Locations.Zone.top) state - in - let new_state = - if (not (Kernel_function.returns_void pdg.fct)) then - let from0 = froms.Function_Froms.deps_return in - let _ = create_fun_output_node pdg (Some new_state) - (Lmap_bitwise.From_Model.LOffset.collapse from0) - in new_state - else new_state - in - store_last_state pdg new_state + let ret = + try Kernel_function.find_return (get_kf pdg) + with Kernel_function.No_Statement -> + Pdg_parameters.abort "No return in a declaration" + in + Pdg_parameters.warning ~once:true ~source:(fst (Stmt.loc ret)) + "no final state. Probably unreachable..."; + None in + (match from_opt with + | None -> () ( defined function : retres already processed. ) + | Some froms -> ( undefined function : add output 0 ) + ( TODO : also add the nodes for the other from ! ) + let state = match last_state with Some s -> s | None -> assert false in + let process_out out (default, from_out) s = + add_from pdg state s out (default, from_out) + in + let from_table = froms.Function_Froms.deps_table in + let new_state = + try Lmap_bitwise.From_Model.fold process_out from_table state + with Lmap_bitwise.From_Model.Cannot_fold -> ( TOP in from_table ) + process_out Locations.Zone.top (false, Locations.Zone.top) state + in + if not (Kernel_function.returns_void pdg.fct) then begin + let from0 = froms.Function_Froms.deps_return in + ignore + (create_fun_output_node + pdg + (Some new_state) + (Lmap_bitwise.From_Model.LOffset.collapse from0)) + end; + store_last_state pdg new_state); let init_state = process_other_inputs pdg in - store_init_state pdg init_state; + store_init_state pdg init_state; add_ctrl_dpds pdg ; - P.debug ~level:2 "finalize_pdg ok"; + debug2 "finalize_pdg ok"; let states = get_states pdg in - let pdg = PdgTypes.Pdg.make pdg.fct pdg.graph states pdg.index - in - pdg + PdgTypes.Pdg.make pdg.fct pdg.graph states pdg.index end (-----------------------------------------------------------------------*) - (** gives needed informations about [lval] : - = location + exact + dependencies + declarations - ) + = location + exact + dependencies + declarations ) let get_lval_infos lval stmt = let decl = Cil.extract_varinfos_from_lval lval in - let dpds, loc = !Db.Value.lval_to_loc_with_deps - ~with_alarms:CilE.warn_none_mode - (Kstmt stmt) - ~deps:Locations.Zone.bottom lval + let dpds, loc = + !Db.Value.lval_to_loc_with_deps + ~with_alarms:CilE.warn_none_mode + (Kstmt stmt) + ~deps:Locations.Zone.bottom lval in - let l_loc = Locations.valid_enumerate_bits loc in - let exact = Locations.valid_cardinal_zero_or_one loc in - (l_loc, exact, dpds, decl) + let l_loc = Locations.valid_enumerate_bits ~for_writing:true loc in + let exact = Locations.valid_cardinal_zero_or_one ~for_writing:true loc in + (l_loc, exact, dpds, decl) (** process assignment {v lval = exp; v} Use the state at ki (before assign) - and returns the new state (after assign). - ) + and returns the new state (after assign). ) let process_asgn pdg state stmt lval exp = - let r_dpds = !Db.From.find_deps_no_transitivity (Kstmt stmt) exp in + let r_dpds = !Db.From.find_deps_no_transitivity stmt exp in let r_decl = Cil.extract_varinfos_from_exp exp in let (l_loc, exact, l_dpds, l_decl) = get_lval_infos lval stmt in - BuildPdg.process_asgn pdg state stmt ~l_loc ~exact ~l_dpds ~l_decl - ~r_dpds ~r_decl - -let process_code_annot pdg stmt _annot = - (* TODO : we could add dependencies to some data if we know how to extract - * then from the annotation... *) - BuildPdg.process_skip pdg stmt - -let process_skip pdg stmt = BuildPdg.process_skip pdg stmt + let state = BuildPdg.process_asgn pdg state stmt + ~l_loc ~exact ~l_dpds ~l_decl ~r_dpds ~r_decl + in Some state (** Add a PDG node and its dependencies for each explicit call argument. *) let process_args pdg st stmt argl = let process_one_arg arg = - let dpds = !Db.From.find_deps_no_transitivity (Kstmt stmt) arg in + let dpds = !Db.From.find_deps_no_transitivity stmt arg in let decl_dpds = Cil.extract_varinfos_from_exp arg in (dpds, decl_dpds) in let arg_dpds = List.map process_one_arg argl in BuildPdg.process_call_args pdg st stmt arg_dpds - (** Add nodes for the call outputs, and add the dependencies according to from_table. To avoid mixing inputs and outputs, [in_state] is the input state @@ -763,30 +803,34 @@ Format.fprintf fmt "\t and \\result %a@." Lmap_bitwise.From_Model.LOffset.pretty froms_deps_return in - Pdg_parameters.debug "%t" print_outputs; - let new_state = - match lvaloption with - | None -> state_before_call - | Some lval -> - let r_dpds = - Lmap_bitwise.From_Model.LOffset.collapse froms_deps_return - in - let (l_loc, exact, l_dpds, l_decl) = get_lval_infos lval stmt in - BuildPdg.process_call_return pdg state_before_call - state_with_inputs stmt - ~l_loc ~exact ~l_dpds ~l_decl - ~r_dpds fct_dpds - in + debug "%t" print_outputs; let process_out out (default, from_out) (state, numout) = let new_state = BuildPdg.process_call_ouput pdg state_with_inputs state stmt numout out default from_out fct_dpds in (new_state, numout+1) in - let (new_state, _num) = - try Lmap_bitwise.From_Model.fold process_out from_table (new_state, 1) + let (state_with_outputs, _num) = + try + Lmap_bitwise.From_Model.fold process_out from_table (state_before_call, 1) with Lmap_bitwise.From_Model.Cannot_fold -> (* TOP in from_table ) - process_out Locations.Zone.top (false, Locations.Zone.top) (new_state, 1) + process_out Locations.Zone.top (false, Locations.Zone.top) + (state_before_call, 1) + in + let new_state = + match lvaloption with + | None -> state_with_outputs + | Some lval -> + let r_dpds = + Lmap_bitwise.From_Model.LOffset.collapse froms_deps_return + in + let (l_loc, exact, l_dpds, l_decl) = get_lval_infos lval stmt in + BuildPdg.process_call_return + pdg + state_with_outputs + state_with_inputs stmt + ~l_loc ~exact ~l_dpds ~l_decl + ~r_dpds fct_dpds in new_state ( process call : {v lvaloption = funcexp (argl); v} @@ -796,7 +840,7 @@ let process_call pdg state stmt lvaloption funcexp argl = let state_before_call = state in let _ = BuildPdg.process_call_node pdg stmt in - let _nb_arg, arg_nodes = process_args pdg state_before_call stmt argl in + let arg_nodes = process_args pdg state_before_call stmt argl in let state_with_args = state in let funcexp_dpds, called_functions = !Db.Value.expr_to_kernel_function @@ -830,7 +874,7 @@ | [] -> let stmt_str = Pretty_utils.sfprintf "%a" !Ast_printer.d_stmt stmt in Extlib.not_yet_implemented - ("pdg with an unknown function call : " ^ stmt_str) + ("pdg with an unknown function call : " ^ stmt_str) | st :: [] -> st | st :: other_states -> let merge s1 s2 = @@ -843,87 +887,79 @@ call_ouputs pdg state_before_call new_state stmt lvaloption froms funcexp_dpds in - new_state - - + Some new_state ( Add a node in the PDG for the conditional statement, and register the statements that are control-dependent on it. ) let process_condition ctrl_dpds_infos pdg state stmt condition = - ( TODO : test if we met this stmt already to avoid recomputing - the control dependencies. ) + let loc_cond = !Db.From.find_deps_no_transitivity stmt condition in + let decls_cond = Cil.extract_varinfos_from_exp condition in - ( let's find the locations used in the condition ) - let loc_cond = !Db.From.find_deps_no_transitivity (Kstmt stmt) condition in - let decls_cond = Cil.extract_varinfos_from_exp condition in - - (let cond_val = !Db.Value.access_expr (Kstmt stmt) condition in) - let controled_stmts = - CtrlDpds.get_if_controled_stmts ctrl_dpds_infos stmt - in - ( - let real_dpd = - let always_false = Locations.Location_Bytes.is_zero cond_val in - if always_false then false - else - let always_true = - not (Locations.Location_Bytes.intersects - cond_val Locations.Location_Bytes.singleton_zero) in - if always_true then false - else true - in - * We cannot ignore de dependencies, even if [real_dpd = false] - * because we lose indirect dependencies... (see BTS#181) - ) + let controled_stmts = CtrlDpds.get_if_controled_stmts ctrl_dpds_infos stmt in + let go_then, go_else = Db.Value.condition_truth_value stmt in + let real = go_then && go_else ( real dpd if we can go in both branches ) in + if not real then + debug + "[process_condition] stmt %d is not a real cond (never goes in '%s')@." + stmt.sid (if go_then then "else" else "then"); ( build a node for the condition and store de control dependencies *) - BuildPdg.process_jump_with_exp pdg stmt controled_stmts + BuildPdg.process_jump_with_exp pdg stmt (real, controled_stmts) state loc_cond decls_cond (** let's add a node for e jump statement (goto, break, continue) and find the statements which are depending on it. - - Loop are processed like gotos because CIL transformations - make them {v while(true) body; v} which is equivalent to - {v L : body ; goto L; v} - Returns are not handled here, but in {!Build.process_return}. *) -let process_jump_or_loop_stmt pdg ctrl_dpds_infos jump = - let controled_stmt_list = +let process_jump_stmt pdg ctrl_dpds_infos jump = + let controled_stmts = CtrlDpds.get_jump_controled_stmts ctrl_dpds_infos jump in - BuildPdg.process_jump pdg jump controled_stmt_list + let real = Db.Value.is_reachable_stmt jump in + if not real then + debug "[process_jump_stmt] stmt %d is not a real jump@." jump.sid; + BuildPdg.process_jump pdg jump (real, controled_stmts) + +(** Loop are processed like gotos because CIL transforms them into +* {v while(true) body; v} which is equivalent to {v L : body ; goto L; v} +* There is a small difference because we have to detect the case where +* the [goto L;] would be unreachable (no real loop). +* This is important because it might lead to infinite loop (see bst#787) +*) +let process_loop_stmt pdg ctrl_dpds_infos loop = + let _entry, back_edges = Stmts_graph.loop_preds loop in + debug2 "[process_loop_stmt] for loop %d : back edges = {%a}@." + loop.sid (Pretty_utils.pp_list Stmt.pretty_sid) back_edges; + let controled_stmts = + CtrlDpds.get_loop_controled_stmts ctrl_dpds_infos loop + in + let real_loop = List.exists (Db.Value.is_reachable_stmt) back_edges in + if not real_loop then + debug "[process_loop_stmt] stmt %d is not a real loop@." loop.sid; + BuildPdg.process_jump pdg loop (real_loop, controled_stmts) (** [return ret_exp;] is equivalent to [out0 = ret_exp; goto END;] * while a simple [return;] is only a [goto END;]. * Here, we assume that the {{:../html/Oneret.html}Oneret} analysis * was used, ie. that it is the only return of the function - * and that it is the last statement. So, the [goto] is not usefull, + * and that it is the last statement. So, the [goto] is not useful, * and the final state is stored to be used later on to compute the outputs. ) let process_return _current_function pdg state stmt ret_exp = let last_state = match ret_exp with | Some exp -> - let loc_exp = !Db.From.find_deps_no_transitivity (Kstmt stmt) exp in + let loc_exp = !Db.From.find_deps_no_transitivity stmt exp in let decls_exp = Cil.extract_varinfos_from_exp exp in BuildPdg.add_retres pdg state stmt loc_exp decls_exp | None -> - let controled_stmt = [] in - BuildPdg.process_jump pdg stmt controled_stmt; + let controled_stmt = Cil_datatype.Stmt.Hptset.empty in + let real = Db.Value.is_reachable_stmt stmt in + BuildPdg.process_jump pdg stmt (real, controled_stmt); state in - BuildPdg.store_last_state pdg last_state - -( -let rec process_labels pdg labels = - match stmt.labels with - | [] -> () - | label :: tail -> Pdg.process_label pdg label; - process_labels pdg labels -*) - + if Db.Value.is_reachable_stmt stmt then + BuildPdg.store_last_state pdg last_state (** Computer is a ForwardsTransfer to use ForwardsDataFlow *) module Computer (Param:sig @@ -931,6 +967,7 @@ val ctrl_dpds_infos : CtrlDpds.t end) = struct let name = "slicingflow" + let pdg_debug fmt = debug fmt let debug = ref false type t = BuildPdg.t_state @@ -940,8 +977,10 @@ let ctrl_dpds_infos = Param.ctrl_dpds_infos + (** place to store information at each point of the program during analysis ) module StmtStartData = struct type data = BuildPdg.t_state + type key = int let states = BuildPdg.get_states current_pdg let clear () = IH.clear states let mem = IH.mem states @@ -952,12 +991,6 @@ let length () = IH.length states end -( - (** place to store information at each point of the program during analysis ) - let stmtStartData: IH.t = BuildPdg.get_states current_pdg -) - let stmt_can_reach = Stmts_graph.stmt_can_reach current_function - let copy (d: t) = d let pretty fmt (v: t) = @@ -977,40 +1010,36 @@ let new_state = computeFirstPredecessor stmt new_ in let is_new, new_state = BuildPdg.test_and_merge_states old new_state in if is_new then Some new_state - else - begin - (if !debug - then P.debug "fix point reached for stmt %d" stmt.sid); - None - end + else (pdg_debug "fix point reached for sid:%d" stmt.sid; None) (** Compute the new state after 'instr' starting from state before 'state'. *) let doInstr stmt instr state = !Db.progress (); - P.debug "doInstr : %a" !Ast_printer.d_instr instr; - match instr with - | Set (lv, exp, _) -> - let new_state = process_asgn current_pdg state stmt lv exp in - Dataflow.Done new_state - | Call (lvaloption,funcexp,argl,_) -> - !Db.progress (); - let new_state = process_call current_pdg state stmt - lvaloption funcexp argl in - Dataflow.Done new_state - | Code_annot (annot, _) -> - process_code_annot current_pdg stmt annot; Dataflow.Default - | Skip _ -> process_skip current_pdg stmt ; Dataflow.Default - | Asm _ -> P.fatal ~current:true "inline assembly instruction" + pdg_debug "doInstr sid:%d : %a" stmt.sid !Ast_printer.d_instr instr; + let state = match instr with + | Call _ when not (Db.Value.is_reachable_stmt stmt) -> + pdg_debug "call sid:%d is unreachable : skip.@." stmt.sid ; + BuildPdg.process_unreachable_call current_pdg state stmt + | _ when not (Db.Value.is_reachable_stmt stmt) -> + pdg_debug "stmt sid:%d is unreachable : skip.@." stmt.sid ; + BuildPdg.process_unreachable current_pdg state stmt + | Set (lv, exp, _) -> process_asgn current_pdg state stmt lv exp + | Call (lvaloption,funcexp,argl,_) -> + !Db.progress (); + process_call current_pdg state stmt lvaloption funcexp argl + | Code_annot _ + | Skip _ -> BuildPdg.process_skip current_pdg state stmt + | Asm _ -> Extlib.not_yet_implemented "inline assembly instruction" + in match state with None -> Dataflow.Default + | Some state -> Dataflow.Done state (** Called before processing the successors of the statements. ) let doStmt (stmt: Cil_types.stmt) (state: t) = - P.debug "doStmt %d @." stmt.sid ; + pdg_debug "doStmt %d @." stmt.sid ; - ( labels are processed while processing the jumps. - process_labels current_pdg labels ; - ) + ( Notice that the stmt labels are processed while processing the jumps. *) match stmt.skind with | Instr _ @@ -1035,9 +1064,12 @@ | Continue _ | Break _ - | Goto _ + | Goto _ -> + process_jump_stmt current_pdg ctrl_dpds_infos stmt; + Dataflow.SDefault + | Loop _ -> - process_jump_or_loop_stmt current_pdg ctrl_dpds_infos stmt; + process_loop_stmt current_pdg ctrl_dpds_infos stmt; Dataflow.SDefault | TryExcept (_, _, _, _) @@ -1045,7 +1077,12 @@ -> Dataflow.SDefault (** Whether to put this statement in the worklist. ) - let filterStmt stmt = Db.Value.is_accessible (Kstmt stmt) + let filterStmt _stmt = true + ( don't use Db.Value.is_reachable_stmt here since we want to build node. + * Use it later in [doInstr] but be carreful about ctrl dpds ! *) + + (** used to optimize the order of the dataflow analysis. *) + let stmt_can_reach = Stmts_graph.stmt_can_reach current_function let doGuard _ _ _ = Dataflow.GDefault, Dataflow.GDefault @@ -1053,15 +1090,34 @@ end +(** Find the statements that are not reachable in CFG (no predecessors) +* to add them as starting point of the dataflow analysis because we need to +* process unreachable control statetemetns in order to have correct +* control dependancies. *) +let ctrl_no_preds stmts = + let rec add acc stmts = match stmts with [] -> acc + | s::tl -> add (add_stmt acc s) tl + and add_stmt acc s = + let acc = if s.preds = [] then s::acc else acc in + match s.skind with + | Instr _ | Return _ | Continue _ | Break _ | Goto _ -> acc + | Block b | Switch (_, b, _, _) | Loop (_, b, _, _, _) -> + add acc b.bstmts + | UnspecifiedSequence seq -> + let b = Cil.block_from_unspecified_sequence seq in + add acc b.bstmts + | If (_, b1, b2, _) -> add (add acc b1.bstmts) b2.bstmts + | TryExcept (_, _, _, _) | TryFinally (_, _, _) -> acc + in add [] stmts + (** Compute and return the PDG for the given function ) let compute_pdg_for_f kf = let pdg = BuildPdg.create kf in let f_locals, f_stmts = - try - let f = Kernel_function.get_definition kf in - f.slocals, f.sbody.bstmts - with Kernel_function.No_Definition -> [], [] + if !Db.Value.use_spec_instead_of_definition kf then [], [] + else let f = Kernel_function.get_definition kf in + f.slocals, f.sbody.bstmts in let init_state = let _ = BuildPdg.process_entry_point pdg f_stmts in @@ -1074,7 +1130,7 @@ BuildPdg.store_last_state pdg state ; let froms = !Db.From.get kf in Some (froms) - | start :: _ -> + | start :: stmts -> let ctrl_dpds_infos = CtrlDpds.compute kf in let module Computer = Computer (struct let current_pdg = pdg @@ -1082,63 +1138,73 @@ end) in let module Compute = Dataflow.ForwardsDataFlow(Computer) in - if Computer.filterStmt start then + if Db.Value.is_reachable_stmt start then begin let init_state = Computer.computeFirstPredecessor start init_state in Computer.StmtStartData.add start.sid init_state ; - Compute.compute [start] ; + let rec add acc l = match l with [] -> acc + | s::tl -> + Computer.StmtStartData.add s.sid BuildPdg.empty_state; + add (s::acc) tl + in + let starts = add [start] (ctrl_no_preds stmts) in + Compute.compute starts ; None end else raise - (Err_Bot - (Printf.sprintf "unreachable entry point (sid %d, function %s)" - start.sid (Kernel_function.get_name kf))) + (Err_Bot + (Printf.sprintf "unreachable entry point (sid:%d, function %s)" + start.sid (Kernel_function.get_name kf))) in let pdg = BuildPdg.finalize_pdg pdg froms in pdg let degenerated top kf = - P.feedback "%s for function %a" - (if top then "Top" else "Bottom") - Kernel_function.pretty_name kf; + Pdg_parameters.feedback "%s for function %a" (if top then "Top" else "Bottom") + Kernel_function.pretty kf; if top then PdgTypes.Pdg.top kf else PdgTypes.Pdg.bottom kf let compute_pdg kf = if not (Db.Value.is_computed ()) then !Db.Value.compute (); - P.feedback "computing for function %a" - Kernel_function.pretty_name kf; + Pdg_parameters.feedback "computing for function %a" Kernel_function.pretty kf; try if is_variadic kf then - Extlib.not_yet_implemented "PDG for a variadic function"; + Extlib.not_yet_implemented "variadic function"; let pdg = compute_pdg_for_f kf in - P.feedback "done for function %a" - Kernel_function.pretty_name kf; + Pdg_parameters.feedback "done for function %a" Kernel_function.pretty kf; - ( Datascope.compute kf; ) pdg with | Err_Bot what -> - P.warning "%s" what ; - degenerated false kf + Pdg_parameters.warning "%s" what ; + degenerated false kf - | PdgTypes.Pdg_Internal_Error what -> - P.failure "%s" what ; - degenerated true kf + | Log.AbortFatal what -> + Pdg_parameters.warning "internal error: %s" what ; + degenerated true kf + + | Log.AbortError what -> + Pdg_parameters.warning "user error: %s" what ; + degenerated true kf | Pdg_state.Cannot_fold -> - P.failure "too imprecise value analysis : abort" ; - degenerated true kf + Pdg_parameters.warning "too imprecise value analysis : abort" ; + degenerated true kf - | Extlib.NotYetImplemented why_nyi -> - P.failure "%s not implemented yet" why_nyi ; - degenerated true kf + | Extlib.NotYetImplemented what -> + Pdg_parameters.warning "not implemented by PDG yet: %s" what ; + degenerated true kf + + | Log.FeatureRequest (who, what) -> + Pdg_parameters.warning "not implemented by [%s] yet: %s" who what ; + degenerated true kf ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/build.mli frama-c-20111001+nitrogen+dfsg/src/pdg/build.mli --- frama-c-20110201+carbon+dfsg/src/pdg/build.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/build.mli 2011-10-10 08:38:30.000000000 +0000 @@ -22,7 +22,7 @@ (* *) (**************************************************************************) -val compute_pdg : Db_types.kernel_function -> PdgTypes.Pdg.t +val compute_pdg : Cil_types.kernel_function -> PdgTypes.Pdg.t (* Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/ctrlDpds.ml frama-c-20111001+nitrogen+dfsg/src/pdg/ctrlDpds.ml --- frama-c-20110201+carbon+dfsg/src/pdg/ctrlDpds.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/ctrlDpds.ml 2011-10-10 08:38:30.000000000 +0000 @@ -22,184 +22,302 @@ (* *) (**************************************************************************) +let dkey = "ctrl-dpds" + open Cil_types -module IH = Inthash open Cil_datatype -module S = struct - type t = Stmt.Set.t - let empty = Stmt.Set.empty - let singleton = Stmt.Set.singleton - - let add = Stmt.Set.add - let remove = Stmt.Set.remove - - let equal = Stmt.Set.equal - - let inter = Stmt.Set.inter - let diff = Stmt.Set.diff - let union = Stmt.Set.union +(============================================================================) +(** Lexical successors ) +(============================================================================*) +(** Compute a graph which provide the lexical successor of each statement s, + ie. the statement which is the next one if 's' is replaced by Nop. + Notice that if 's' is an If, Loop, ... + the considered statement is the whole block. + + Example : (1) x = 3; + (2) if (c) (3) y = 3; (4) goto L; else (5) z = 8; + (6) while (c--) (7) x++; + (8) L : return x; + + (1) -> (2) -> (6) -> (8) + (3) -> (4) -> (6) + (5) -> (6) + (7) -> (6) - let elements = Stmt.Set.elements - let pretty = Stmt.Set.pretty -end + *) +module Lexical_successors : sig -type t_info = - | ToReturn of S.t - | ToInfinity of S.t - | Init - -module State = struct - type t = t_info - - let inter a b = match a,b with - | Init, Init -> Init - | ToReturn v, Init | Init, ToReturn v -> ToReturn v - | ToInfinity v, Init | Init, ToInfinity v -> ToInfinity v - | ToReturn v, ToReturn v' -> ToReturn ( S.inter v v') - | ToInfinity v, ToInfinity v' -> ToInfinity ( S.inter v v') - | ToReturn v, ToInfinity _ | ToInfinity _, ToReturn v -> ToReturn v - - let equal a b = match a,b with - | Init, Init -> true - | ToReturn v, ToReturn v' -> S.equal v v' - | ToInfinity v, ToInfinity v' -> S.equal v v' - | _ -> false - - let add stmt set = match set with - | Init -> Init - | ToReturn set -> ToReturn (S.add stmt set) - | ToInfinity set -> ToInfinity (S.add stmt set) - - let pretty fmt d = - match d with - | Init -> - Format.fprintf fmt "Top" - | ToReturn d -> Format.fprintf fmt "{%a}_ret" S.pretty d - | ToInfinity d -> Format.fprintf fmt "{%a}_oo" S.pretty d -end + type t + val compute : Cil_types.kernel_function -> t -module States = struct - type t = State.t IH.t - let create = IH.create - let add = IH.add - let find = IH.find - let pretty fmt infos = - IH.iter - (fun k v -> Format.fprintf fmt "Stmt:%d\n%a\n======" k State.pretty v) - infos -end + (** @return the lexical successor of stmt in graph. + @raise Not_found if 'stmt' has no successor in 'graph' + ) + val find : t -> Cil_types.stmt -> Cil_types.stmt +end = struct -type t = Lexical_successors.t States.t + let dkey = "lex-succs" -module Computer (Param:sig - val states : States.t - val end_point : int - end) = struct - - let name = "ctrlDpds" - let debug = ref false - - type t = State.t - let pretty = State.pretty - - module StmtStartData = struct - type data = t - let clear () = IH.clear Param.states - let mem = IH.mem Param.states - let find = IH.find Param.states - let replace = IH.replace Param.states - let add = IH.add Param.states - let iter f = IH.iter f Param.states - let length () = IH.length Param.states - end + (** Type of the graph ) + type t = Cil_types.stmt Stmt.Hashtbl.t + let pp_stmt fmt s = Format.fprintf fmt "@[sid:%d(%a)@]" s.sid Stmt.pretty s - let combineStmtStartData _stmt ~old new_ = - let result = ( inter old *) new_ in - if State.equal result old then None else Some result - - let combineSuccessors = State.inter + (** Add links from each [prev] in [prev_list] to [next]. *) + let add_links graph prev_list next = match prev_list with + | [] -> () + | _ -> + let link prev = + try ignore (Stmt.Hashtbl.find graph prev) + with Not_found -> + Pdg_parameters.debug ~dkey "add @[%a@,-> %a@]" + pp_stmt prev pp_stmt next; + Stmt.Hashtbl.add graph prev next + in List.iter link prev_list + + (** Add links from [prev_list] to [stmt]. + * (ie. [stmt] is the lexical successor of every statements in [prev_list]) + * and build the links inside [stmt] (when it contains blocks) + * @return a list of the last statements in [stmt] to continue processing + * with the statement that follows. + *) + let rec process_stmt graph ~prev_list ~stmt = + Pdg_parameters.debug ~dkey "computing for statement %a@." + pp_stmt stmt; + match stmt.skind with + | If (_,bthen,belse,_) -> + let _ = add_links graph prev_list stmt in + let last_then = process_block graph bthen in + let last_else = process_block graph belse in + let prev_list = match last_then, last_else with + | [], [] -> [ stmt ] + | last, [] | [], last -> stmt::last + | last_then, last_else -> last_then @ last_else + in prev_list + + | Switch (_,blk,_,_) + | Block blk -> + let _ = add_links graph prev_list stmt in + process_block graph blk + | UnspecifiedSequence seq -> + let _ = add_links graph prev_list stmt in + process_block graph (Cil.block_from_unspecified_sequence seq) + + | Loop (_,body,_,_,_) -> + let prev_list = match body.bstmts with + | [] -> + let _ = add_links graph prev_list stmt in [ stmt ] + | head::_ -> + let _ = add_links graph prev_list head in + let last_list = process_block graph body in + let _ = add_links graph last_list stmt in + stmt::[] + in prev_list + + | Instr _ + | Return _ | Goto _ | Break _ | Continue _ + | TryFinally _ | TryExcept _ + -> let _ = add_links graph prev_list stmt in [stmt] + + (** Process each statement in blk with no previous statement to begin with. + * Then process each statement in the statement list + * knowing that the first element of 'tail' + * is the successor of every statement in prev_list. + * @return a list of the last statements in tail or prev_list if tail=[]. + *) + and process_block graph blk = + let rec process_stmts prev_list stmts = match stmts with + | [] -> prev_list + | s :: tail -> + let s_last_stmts = process_stmt graph prev_list s in + process_stmts s_last_stmts tail + in process_stmts [] blk.bstmts + + (** Compute the lexical successor graph for function kf *) + let compute kf = + Pdg_parameters.debug ~dkey "computing for function %s@." + (Kernel_function.get_name kf); + if !Db.Value.use_spec_instead_of_definition kf then Stmt.Hashtbl.create 0 + else let graph = Stmt.Hashtbl.create 17 in + let f = Kernel_function.get_definition kf in + let _ = process_block graph f.sbody in graph - let doStmt stmt = - if stmt.sid = Param.end_point then - Dataflow.Done (ToInfinity (S.singleton stmt)) - else - Dataflow.Post (fun data -> State.add stmt data) + (** @return the lexical successor of stmt in graph. + @raise Not_found if 'stmt' has no successor in 'graph' ie when it is [return]. + ) + let find graph stmt = + try Stmt.Hashtbl.find graph stmt + with Not_found -> + Pdg_parameters.debug ~dkey ~level:2 "not found for stmt:%d@." stmt.sid; + raise Not_found +end - let doInstr _ _ _ = Dataflow.Default +(============================================================================*) +(** Postdominators (with infine path extension) ) +(============================================================================*) +module PdgPostdom : sig + + type t + + val compute : kernel_function -> t + + (** @param with_s tells if the statement has to be added to its postdom. + * The returned boolean tells if there is a path to [return] ) + val get : t -> with_s:bool -> stmt -> bool Stmt.Hptset.t + +end = struct + + module State = struct + type t = + | ToReturn of Stmt.Hptset.t + | ToInfinity of Stmt.Hptset.t + | Init + + let inter a b = match a,b with + | Init, Init -> Init + | ToReturn v, Init | Init, ToReturn v -> ToReturn v + | ToInfinity v, Init | Init, ToInfinity v -> ToInfinity v + | ToReturn v, ToReturn v' -> ToReturn ( Stmt.Hptset.inter v v') + | ToInfinity v, ToInfinity v' -> ToInfinity ( Stmt.Hptset.inter v v') + | ToReturn v, ToInfinity _ | ToInfinity _, ToReturn v -> ToReturn v + + let equal a b = match a,b with + | Init, Init -> true + | ToReturn v, ToReturn v' -> Stmt.Hptset.equal v v' + | ToInfinity v, ToInfinity v' -> Stmt.Hptset.equal v v' + | _ -> false + + let add stmt set = match set with + | Init -> Init + | ToReturn set -> ToReturn (Stmt.Hptset.add stmt set) + | ToInfinity set -> ToInfinity (Stmt.Hptset.add stmt set) + + let pretty fmt d = + match d with + | Init -> Format.fprintf fmt "Top" + | ToReturn d -> Format.fprintf fmt "{%a}_ret" Stmt.Hptset.pretty d + | ToInfinity d -> Format.fprintf fmt "{%a}_oo" Stmt.Hptset.pretty d + end - let filterStmt _stmt _next = true - (* assert (Db.ToReturn.is_accessible (Kstmt next)); - Db.ToReturn.is_accessible (Kstmt stmt) *) + type t = State.t Stmt.Hashtbl.t - let funcExitData = ToReturn S.empty + let pretty fmt infos = + Stmt.Hashtbl.iter + (fun k v -> Format.fprintf fmt "Stmt:%d\n%a\n======" k.sid State.pretty v) + infos -end + let is_in_stmts iter s stmts = + try iter (fun s' -> if s.sid = s'.sid then raise Exit) stmts; false + with Exit -> true + + (** change [succs] so move the edges [entry -> loop] to [entry -> head] *) + let succs stmt = + let modif acc s = match s.skind with + | Loop _ -> + let head = match s.succs with | [head] -> head | _ -> assert false in + let entry, _back_edges = Stmts_graph.loop_preds s in + if is_in_stmts List.iter stmt entry then head::acc else s::acc + | _ -> s::acc + in List.fold_left modif [] stmt.succs + + (** change [preds] so remove the edges [entry <- loop] + * and to add the edges [entry <- head] ) + let preds stmt = match stmt.skind with + | Loop _ -> ( remove edges from entry to loop ) + let _entry, back_edges = Stmts_graph.loop_preds stmt in back_edges + | _ -> + let modif acc s = match s.skind with + | Loop _ -> + let entry, _back_edges = Stmts_graph.loop_preds s in + s::entry@acc + | _ -> s::acc + in List.fold_left modif [] stmt.preds + + let add_postdom infos start init = + let get s = try Stmt.Hashtbl.find infos s with Not_found -> State.Init in + let do_stmt stmt = match succs stmt with + | [] when stmt.sid = start.sid -> + Some (State.ToReturn (Stmt.Hptset.empty)) + | [] -> assert false + | s::tl -> + let add_get s = State.add s (get s) in + let combineSuccessors st s = State.inter st (add_get s) in + let st = List.fold_left combineSuccessors (add_get s) tl in + let old = get stmt in + let new_st = ( don't need to State.inter old ) st in + if State.equal old new_st then None + else Some new_st + in + let todo = Queue.create () in + let add_todo p = + if is_in_stmts Queue.iter p todo then () else Queue.add p todo + in + let rec do_todo () = + try + let s = Queue.take todo in + let _ = match do_stmt s with + | None -> ( finished with that one ) () + | Some st -> ( store state and add preds ) + Stmt.Hashtbl.add infos s st; List.iter add_todo (preds s) + in do_todo () + with Queue.Empty -> () + in + let _ = Stmt.Hashtbl.add infos start init in + let _ = List.iter (fun p -> Queue.add p todo) (preds start) in + do_todo () + + let compute kf = + let infos = Stmt.Hashtbl.create 50 in + let return = + try Kernel_function.find_return kf + with Kernel_function.No_Statement -> + Pdg_parameters.fatal "No return statement for a function with body %a" + Kernel_function.pretty kf + in + let _ = add_postdom infos return (State.ToReturn (Stmt.Hptset.empty)) in + let stmts = + if !Db.Value.use_spec_instead_of_definition kf then + invalid_arg "[traces] cannot compute for a leaf function" + else + let f = Kernel_function.get_definition kf in f.sallstmts + in + let remove_top s = + try ignore (Stmt.Hashtbl.find infos s) with Not_found -> + Pdg_parameters.debug ~dkey "compute infinite path to sid:%d" s.sid; + add_postdom infos s (State.ToInfinity (Stmt.Hptset.empty)) + in + let _ = List.iter remove_top stmts in + infos -let go infos end_point = - let module Computer = Computer (struct - let end_point = end_point.sid - let states = infos - end) - in let module Compute = Dataflow.BackwardsDataFlow(Computer) in - Compute.compute [end_point] + let get infos ~with_s stmt = + try + let stmt_to_ret, postdoms = match Stmt.Hashtbl.find infos stmt with + | State.ToInfinity postdoms -> false, postdoms + | State.ToReturn postdoms -> true, postdoms + | State.Init -> assert false + in let postdoms = + if with_s then Stmt.Hptset.add stmt postdoms else postdoms + in + Pdg_parameters.debug ~dkey ~level:2 + "get_postdoms for sid:%d (%s) = %a (%spath to ret)@." + stmt.sid (if with_s then "with" else "without") + Stmt.Hptset.pretty postdoms (if stmt_to_ret then "" else "no "); + stmt_to_ret, postdoms + with Not_found -> assert false -let compute_on_infinite_traces infos tops = - let rec remove_top stmts = match stmts with - | [] -> () - | s :: stmts -> - if States.find infos s.sid = Init then go infos s else (); - remove_top stmts - in remove_top tops +end +(============================================================================*) +(** Compute information needed for control dependencies ) +(============================================================================) -let compute_infos kf = - let stmts = - try - let f = Kernel_function.get_definition kf in f.sallstmts - with Kernel_function.No_Definition -> invalid_arg - "[traces] cannot compute for a leaf function" - in - let infos = States.create 50 in - (List.iter (fun s -> States.add s.sid (ToReturn (S.empty))) stmts;) - (List.iter (fun s -> States.add s.sid (ToReturn (S.singleton s))) stmts;) - ( let return = find_return kf in go return; ) - let init tops s = - let tops, postdom = - try tops, ToReturn (!Db.Postdominators.stmt_postdominators kf s) - with Db.Postdominators.Top -> s::tops, Init - in - States.add infos s.sid postdom ; - tops - in - let tops = List.fold_left init [] stmts in - let _ = match tops with - | [] -> () - | _ -> - begin - Cil.log "[traces] computing for function %a" - Kernel_function.pretty_name kf; - Cil.log "[traces] WARNING : experimental feature..."; - Cil.log " -> infinite loop processing" ; - compute_on_infinite_traces infos tops - end - in infos +type t = Lexical_successors.t PdgPostdom.t let compute kf = let lex_succ_graph = Lexical_successors.compute kf in - let ctrl_dpds_infos = compute_infos kf in + let ctrl_dpds_infos = PdgPostdom.compute kf in (lex_succ_graph, ctrl_dpds_infos) -let get_postdoms infos ~without stmt = - try - let stmt_to_ret, postdoms = match States.find infos stmt.sid with - | ToInfinity postdoms -> false, postdoms - | ToReturn postdoms -> true, postdoms - | Init -> assert false - in let postdoms = if without then S.remove stmt postdoms else postdoms in - stmt_to_ret, postdoms - with Not_found -> assert false - (** Compute the PDB(A,B) set used in the control dependencies algorithm. * Roughly speaking, it gives {v (\{B\} U postdom(B))-postdom(A) v}. * It means that if S is in the result, it postdominates B but not A. @@ -209,23 +327,29 @@ (see the document to know more about the applied algorithm) ) let pd_b_but_not_a infos stmt_a stmt_b = - if stmt_a.sid = stmt_b.sid then S.empty + if stmt_a.sid = stmt_b.sid then Stmt.Hptset.empty else begin - let a_to_ret, postdom_a = get_postdoms infos ~without:true stmt_a in - let b_to_ret, postdom_b = get_postdoms infos ~without:false stmt_b in + let a_to_ret, postdom_a = PdgPostdom.get infos ~with_s:false stmt_a in + let b_to_ret, postdom_b = PdgPostdom.get infos ~with_s:true stmt_b in let res = match a_to_ret, b_to_ret with - | true, true | false, false -> S.diff postdom_b postdom_a + | true, true | false, false -> Stmt.Hptset.diff postdom_b postdom_a | true, false -> postdom_b | false, true -> ( no path [a, ret] but path [b, ret] * possible when a there is a jump, because then we have * either (A=G, B=S) or (A=S, B=L) ) - S.empty ( because we don't want b postdoms to depend on the jump ) + Stmt.Hptset.empty ( because we don't want b postdoms + to depend on the jump ) in - Pdg_parameters.debug ~level:2 "pd_b_but_not_a for a=%d b=%d = %a" - stmt_a.sid stmt_b.sid S.pretty res; - res + Pdg_parameters.debug ~dkey ~level:2 + "pd_b_but_not_a for a=sid:%d b=sid:%d = %a" + stmt_a.sid stmt_b.sid Stmt.Hptset.pretty res; + res end +(============================================================================*) +(** Control dependencies ) +(============================================================================*) + (** @return the statements which are depending on the condition. * * {v = U (PDB (if, succs(if)) v} @@ -233,49 +357,66 @@ ) let get_if_controled_stmts ctrl_dpds_infos stmt = let _, infos = ctrl_dpds_infos in - let add_pdb_s set succ = S.union set (pd_b_but_not_a infos stmt succ) in - let controled_stmts = List.fold_left add_pdb_s S.empty stmt.succs in - Pdg_parameters.debug "controled_stmt for cond %d = %a" - stmt.sid S.pretty controled_stmts; - S.elements controled_stmts + let add_pdb_s set succ = + Stmt.Hptset.union set (pd_b_but_not_a infos stmt succ) + in + let controled_stmts = List.fold_left add_pdb_s Stmt.Hptset.empty stmt.succs in + Pdg_parameters.debug ~dkey "controled_stmt for cond sid:%d = %a" + stmt.sid Stmt.Hptset.pretty controled_stmts; + controled_stmts + +let jump_controled_stmts infos jump label lex_suc = + Pdg_parameters.debug ~dkey ~level:2 + "lex_succ sid:%d = sid:%d" jump.sid lex_suc.sid; + Pdg_parameters.debug ~dkey ~level:2 + "jump succ sid:%d = sid:%d" jump.sid label.sid; + let controled_stmts = + if lex_suc.sid = label.sid then begin + ( the label is the jump lexical successor: no dpds *) + Pdg_parameters.debug ~dkey "useless jump sid:%d (label = lex_succ = %d)" + jump.sid lex_suc.sid; + Stmt.Hptset.empty + end else + let pdb_jump_lex_suc = pd_b_but_not_a infos jump lex_suc in + let pdb_lex_suc_label = pd_b_but_not_a infos lex_suc label in + let pdb_lex_suc_label = + Stmt.Hptset.remove lex_suc pdb_lex_suc_label + in Stmt.Hptset.union pdb_jump_lex_suc pdb_lex_suc_label + in + controled_stmts (** let's find the statements which are depending on -* the jump statement (goto, break, continue, loop) = +* the jump statement (goto, break, continue) = {v PDB(jump,lex_suc) U (PDB(lex_suc,label) - lex_suc) v} (see the document to know more about the applied algorithm). ) let get_jump_controled_stmts ctrl_dpds_infos jump = let lex_succ_graph, infos = ctrl_dpds_infos in - let controled_stmts = - try - let lex_suc = Lexical_successors.find lex_succ_graph jump in - Pdg_parameters.debug ~level:2 "lex_succ %d = %d" jump.sid lex_suc.sid; - match jump.succs with - | [label] -> - Pdg_parameters.debug ~level:2 "jump succ %d = %d" jump.sid label.sid; - if lex_suc.sid = label.sid then begin - ( the label is the jump lexical successor: no dpds ) - Pdg_parameters.debug "useless jump %d" jump.sid; - S.empty - end else - let pdb_jump_lex_suc = pd_b_but_not_a infos jump lex_suc in - let pdb_lex_suc_label = pd_b_but_not_a infos lex_suc label in - let pdb_lex_suc_label = S.remove lex_suc pdb_lex_suc_label in - S.union pdb_jump_lex_suc pdb_lex_suc_label - | _ -> assert false - with Not_found -> - Pdg_parameters.debug "lex_succ %d = (none)" jump.sid; - ( no lexical successor : every postdom (jump) depend on jump. *) - let _, pd_jump = (get_postdoms infos ~without:false jump) in - S.remove jump pd_jump + let lex_suc = + try Lexical_successors.find lex_succ_graph jump + with Not_found -> assert false in - Pdg_parameters.debug "controled_stmt for jump %d = %a" - jump.sid S.pretty controled_stmts; - let controled_stmt_list = S.elements controled_stmts in - controled_stmt_list + let label = match jump.succs with | [label] -> label | _ -> assert false in + let controled_stmts = jump_controled_stmts infos jump label lex_suc in + Pdg_parameters.debug ~dkey "controled_stmt for jump sid:%d = %a" + jump.sid Stmt.Hptset.pretty controled_stmts; + controled_stmts -let display = States.pretty +(** Try to process [while(1) S; LS: ] as [L: S; goto L; LS: ] ) +let get_loop_controled_stmts ctrl_dpds_infos loop = + let lex_succ_graph, infos = ctrl_dpds_infos in + let lex_suc = + try Lexical_successors.find lex_succ_graph loop + with Not_found -> ( must have at least a return ) assert false + in + let jump = loop in + let label = match loop.succs with [head] -> head | _ -> assert false in + let controled_stmts = jump_controled_stmts infos jump label lex_suc in + Pdg_parameters.debug ~dkey "controled_stmt for loop sid:%d = %a" + loop.sid Stmt.Hptset.pretty controled_stmts; + controled_stmts +(============================================================================) ( Local Variables: compile-command: "make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/ctrlDpds.mli frama-c-20111001+nitrogen+dfsg/src/pdg/ctrlDpds.mli --- frama-c-20110201+carbon+dfsg/src/pdg/ctrlDpds.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/ctrlDpds.mli 2011-10-10 08:38:30.000000000 +0000 @@ -22,6 +22,7 @@ (* *) (************************************************************************) +( Internal information about control dependencies ) type t ( Compute some information on the function in order to be able to compute @@ -30,7 +31,7 @@ ( Compute the list of the statements that should have a control dependency on the given IF statement. *) -val get_if_controled_stmts : t -> Cil_types.stmt -> Cil_types.stmt list +val get_if_controled_stmts : t -> Cil_types.stmt -> Cil_datatype.Stmt.Hptset.t (** Compute the list of the statements that should have a control dependency * on the given jump statement. This statement can be a [goto] of course, @@ -38,7 +39,8 @@ make them of the form {v while(true) body; v} which is equivalent to {v L : body ; goto L; v} * ) -val get_jump_controled_stmts : t -> Cil_types.stmt -> Cil_types.stmt list +val get_jump_controled_stmts : t -> Cil_types.stmt -> Cil_datatype.Stmt.Hptset.t +val get_loop_controled_stmts : t -> Cil_types.stmt -> Cil_datatype.Stmt.Hptset.t ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/lexical_successors.ml frama-c-20111001+nitrogen+dfsg/src/pdg/lexical_successors.ml --- frama-c-20110201+carbon+dfsg/src/pdg/lexical_successors.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/lexical_successors.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,129 +0,0 @@ -(**************************************************************************) -(* ) -( This file is part of Frama-C. ) -( ) -( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( INRIA (Institut National de Recherche en Informatique et en ) -( Automatique) ) -( ) -( you can redistribute it and/or modify it under the terms of the GNU ) -( Lesser General Public License as published by the Free Software ) -( Foundation, version 2.1. ) -( ) -( It 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 Lesser General Public License for more details. ) -( ) -( See the GNU Lesser General Public License version v2.1 ) -( for more details (enclosed in the file licenses/LGPLv2.1). ) -( *) -(************************************************************************) - -( Compute a graph which provide the lexical successor of each statement s, - ie. the statement which is the next one if 's' is replaced by Nop. - Notice that if 's' is an If, Loop, ... - the considered statement is the whole block. - - Example : (1) x = 3; - (2) if (c) (3) y = 3; (4) goto L; else (5) z = 8; - (6) while (c--) (7) x++; - (8) L : return x; - - (1) -> (2) -> (6) -> (8) - (3) -> (4) -> (6) - (5) -> (6) - (7) -> (6) - *) - -open Cil_types - -(** Add a link prev -> next in the graph. - Do nothing if prev or next is Kglobal. - *) -let add_link graph ~prev ~next = - match (prev, next) with - | (Kglobal, _) -> () - | (_, Kglobal) -> () - | (Kstmt s_prev, Kstmt s_next) -> - let prev_id = s_prev.sid in - try - ignore (Inthash.find graph prev_id) - with Not_found -> - Pdg_parameters.debug "[lexical successor] add %d -> %d" - prev_id s_next.sid; - Inthash.add graph prev_id s_next - -(** Add links from each prev in prev_list to next. *) -let add_links graph prev_list next = - let link prev = add_link graph prev next in - List.iter link prev_list - -(** Add links from prev_list to stmt, - (ie. 'stmt' is the lexical succesor of every statements in prev_list) - and build the links inside stmt (when it contains blocks) - @return a list of the last statements in stmt to continue processing - with the statement that follows. - *) -let rec process_stmt graph ~prev_list ~stmt = - let ki_stmt = Kstmt stmt in - - add_links graph prev_list ki_stmt; - - match stmt.skind with - | If (_,bthen,belse,_) -> - let last_then = process_block graph bthen in - let last_else = process_block graph belse in - last_then @ last_else - - | Switch (_,blk,_,_) - | Block blk -> process_block graph blk - | UnspecifiedSequence seq -> - process_block graph (Cil.block_from_unspecified_sequence seq) - | Loop (_,body,_,_,_) -> - let last_list = process_block graph body in - add_links graph last_list ki_stmt; [ki_stmt] - - | Instr _ - | Return _ | Goto _ | Break _ | Continue _ - | TryFinally _ | TryExcept _ - -> [ki_stmt] - -(** Process each statement in tail (statement list) - knowing that the first element of 'tail' - is the successor of every statement in prev_list. - @return a list of the last statements in tail or prev_list if tail=[]. - *) -and process_tail graph prev_list tail = - match tail with - | [] -> prev_list - | s :: tail -> let s_last_stmt = process_stmt graph prev_list s in - let tail_last_stmt = process_tail graph s_last_stmt tail - in tail_last_stmt - -(** Process each statement in blk with no previous statement to begin with *) -and process_block graph blk = process_tail graph [Kglobal] blk.bstmts - -(** Type of the graph *) -type t = Cil_types.stmt Inthash.t - -(** Compute the lexical successor graph for function kf *) -let compute kf = - Pdg_parameters.debug "[lexical successor] computing for function %s@." - (Kernel_function.get_name kf); - let graph = Inthash.create 50 in - match kf.Db_types.fundec with - | Db_types.Declaration _ -> graph - | Db_types.Definition (f, _) -> - let _ = process_block graph f.sbody in graph - -(** @return the lexical successor of stmt in graph. - @raise Not_found if 'stmt' has no successor in 'graph'. - *) -let find graph stmt = - try Inthash.find graph stmt.sid - with Not_found -> - assert (match stmt.skind with Return _ -> true | _ -> false); - raise Not_found diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/macros.ml frama-c-20111001+nitrogen+dfsg/src/pdg/macros.ml --- frama-c-20110201+carbon+dfsg/src/pdg/macros.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/macros.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -(**************************************************************************) -(* ) -( This file is part of Frama-C. ) -( ) -( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( INRIA (Institut National de Recherche en Informatique et en ) -( Automatique) ) -( ) -( you can redistribute it and/or modify it under the terms of the GNU ) -( Lesser General Public License as published by the Free Software ) -( Foundation, version 2.1. ) -( ) -( It 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 Lesser General Public License for more details. ) -( ) -( See the GNU Lesser General Public License version v2.1 ) -( for more details (enclosed in the file licenses/LGPLv2.1). ) -( *) -(**************************************************************************) - -let bug msg = raise (PdgTypes.Pdg_Internal_Error msg) - -let cbug cond msg = if not cond then bug msg - -let pretty_node fmt n = PdgTypes.Node.pretty fmt n - -let get_pdg_kf pdg = PdgTypes.Pdg.get_kf pdg - -let pdg_name pdg = Kernel_function.get_name (get_pdg_kf pdg) - - -(* -Local Variables: -compile-command: "LC_ALL=C make -C ../.." -End: -) diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/marks.ml frama-c-20111001+nitrogen+dfsg/src/pdg/marks.ml --- frama-c-20110201+carbon+dfsg/src/pdg/marks.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/marks.ml 2011-10-10 08:38:30.000000000 +0000 @@ -102,9 +102,9 @@ let translate_out_mark _pdg m2m other_rqs (call, l) = let add_list l_out_m called_kf rqs = + let called_pdg = !Db.Pdg.get called_kf in + let m2m = m2m (Some call) called_pdg in try - let called_pdg = !Db.Pdg.get called_kf in - let m2m = m2m (Some call) called_pdg in let node_marks = call_out_marks_to_called called_pdg m2m ~rqs:[] l_out_m in (called_pdg, PdgMarks.SelList node_marks)::rqs @@ -147,14 +147,14 @@ version for a source function). ) module F_Proj (C : PdgMarks.T_Config) : PdgMarks.T_Proj with type t_mark = C.M.t - and type t_fct = (C.M.t, C.M.t_call_info) PdgIndex.FctIndex.t - = -struct + and type t_call_info = C.M.t_call_info += struct module F = Db.Pdg.F_FctMarks (C.M) type t_mark = C.M.t - type t_fct = (C.M.t, C.M.t_call_info) PdgIndex.FctIndex.t + type t_call_info = C.M.t_call_info + type t_fct = F.t_fi type t_fct_info = F.t type t = t_fct_info Varinfo.Hashtbl.t diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/marks.mli frama-c-20111001+nitrogen+dfsg/src/pdg/marks.mli --- frama-c-20110201+carbon+dfsg/src/pdg/marks.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/marks.mli 2011-10-10 08:38:30.000000000 +0000 @@ -70,7 +70,7 @@ module F_Proj (C : PdgMarks.T_Config) : PdgMarks.T_Proj with type t_mark = C.M.t - and type t_fct = (C.M.t, C.M.t_call_info) PdgIndex.FctIndex.t + and type t_call_info = C.M.t_call_info ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/Pdg.mli frama-c-20111001+nitrogen+dfsg/src/pdg/Pdg.mli --- frama-c-20110201+carbon+dfsg/src/pdg/Pdg.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/Pdg.mli 2011-10-10 08:38:30.000000000 +0000 @@ -30,29 +30,29 @@ module Register : sig (** [stmt] is a call in the [pdg] function. * Interprocedural information is provided to know which marks have to be - * propagatedfrom the called funciton. + * propagatedfrom the called funciton. * [in_marks_to_caller] translate this [t_info_caller_inputs] * into a (node, mark) list where the marks are filtered by a m2m function. * Ths result is added to the [rqs] list which is empty by default. ) - val in_marks_to_caller : + val in_marks_to_caller : PdgTypes.Pdg.t -> Cil_types.stmt -> ('t_mark PdgMarks.t_m2m) -> - ?rqs:('t_mark PdgMarks.t_select) -> + ?rqs:('t_mark PdgMarks.t_select) -> 't_mark PdgMarks.t_info_caller_inputs -> 't_mark PdgMarks.t_select - ( similar to [in_marks_to_caller] except that it is done + ( similar to [in_marks_to_caller] except that it is done for every callers of the function. *) val translate_in_marks : - PdgTypes.Pdg.t -> 't_mark PdgMarks.t_info_caller_inputs + PdgTypes.Pdg.t -> 't_mark PdgMarks.t_info_caller_inputs -> ?m2m:'t_mark PdgMarks.t_call_m2m -> 't_mark PdgMarks.t_pdg_select -> 't_mark PdgMarks.t_pdg_select (** similar to [in_marks_to_caller] except that it is for the outputs - * of a function propagated into its calls ) + of a function propagated into its calls ) val call_out_marks_to_called : PdgTypes.Pdg.t -> 't_mark PdgMarks.t_m2m -> - ?rqs:('t_mark PdgMarks.t_select) -> + ?rqs:('t_mark PdgMarks.t_select) -> (PdgIndex.Signature.t_out_key 't_mark) list -> 't_mark PdgMarks.t_select @@ -64,10 +64,10 @@ -> 't_mark PdgMarks.t_pdg_select -> 't_mark PdgMarks.t_pdg_select - ( Full backward interprocedural propagation. + ( Full backward interprocedural propagation. * Can be configured using the funtor parameter. * Used for instance in [Sparecode]. ) - module F_Proj (C : PdgMarks.T_Config) : PdgMarks.T_Proj - with type t_mark = C.M.t - and type t_fct = (C.M.t, C.M.t_call_info) PdgIndex.FctIndex.t + module F_Proj (C : PdgMarks.T_Config) : PdgMarks.T_Proj + with type t_mark = C.M.t + and type t_call_info = C.M.t_call_info end diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/pdg_parameters.ml frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_parameters.ml --- frama-c-20110201+carbon+dfsg/src/pdg/pdg_parameters.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_parameters.ml 2011-10-10 08:38:30.000000000 +0000 @@ -29,13 +29,16 @@ let help = "Program Dependence Graph" end) +let output = add_group "Output" + module BuildAll = - False + WithOutput (struct let option_name = "-pdg" let help = - "build the dependence graph of each function for the slicing tool" + "build the dependence graph of each function" let kind = `Tuning + let output_by_default = false end) module BuildFct = @@ -47,6 +50,8 @@ let kind = `Tuning end) + +let () = Plugin.set_group output module PrintBw = False(struct let option_name = "-codpds" @@ -54,6 +59,7 @@ let kind = `Tuning end) +let () = Plugin.set_group output module DotBasename = EmptyString (struct @@ -62,13 +68,3 @@ let help = "put the PDG of function <f> in basename.f.dot" let kind = `Tuning end) - -module DotPostdomBasename = - EmptyString - (struct - let option_name = "-dot-postdom" - let arg_name = "f" - let help = "put the postdominators of function <f> in basename.f.dot" - let kind = `Tuning - end) - diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/pdg_parameters.mli frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_parameters.mli --- frama-c-20110201+carbon+dfsg/src/pdg/pdg_parameters.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_parameters.mli 2011-10-10 08:38:30.000000000 +0000 @@ -24,13 +24,10 @@ include Plugin.S -module BuildAll: Plugin.BOOL +module BuildAll: Plugin.WithOutput -module BuildFct: Plugin.STRING_SET +module BuildFct: Plugin.String_set -module PrintBw: Plugin.BOOL - -module DotBasename: Plugin.STRING - -module DotPostdomBasename: Plugin.STRING +module PrintBw: Plugin.Bool +module DotBasename: Plugin.String diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/pdg_state.ml frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_state.ml --- frama-c-20110201+carbon+dfsg/src/pdg/pdg_state.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_state.ml 2011-10-10 08:38:30.000000000 +0000 @@ -28,8 +28,9 @@ was last defined. ) +let dkey = "state" + module P = Pdg_parameters -module M = Macros open PdgTypes exception Cannot_fold @@ -51,7 +52,7 @@ Locations.Zone.pretty state.under_outputs let add_loc_node state ~exact loc node = - P.debug ~level:2 "[pdg state] add_loc_node (%s) : node %a -> %a@." + P.debug ~dkey ~level:2 "add_loc_node (%s) : node %a -> %a@." (if exact then "exact" else "merge") PdgTypes.Node.pretty node Locations.Zone.pretty loc ; @@ -61,7 +62,7 @@ if exact then Locations.Zone.link state.under_outputs loc else state.under_outputs in - P.debug ~level:2 "add_loc_node -> %a" pretty state; + P.debug ~dkey ~level:2 "add_loc_node -> %a" pretty state; make new_loc_info new_outputs (** this one is very similar to [add_loc_node] except that @@ -81,7 +82,9 @@ make new_loc_info new_outputs let test_and_merge ~old new_ = - if LocInfo.is_included new_.loc_info old.loc_info then (false, old) + if LocInfo.is_included new_.loc_info old.loc_info + && Locations.Zone.is_included old.under_outputs new_.under_outputs + then (false, old) else let new_loc_info = LocInfo.join old.loc_info new_.loc_info in let new_outputs = @@ -111,15 +114,15 @@ let z = if Locations.Zone.equal loc z then Some loc - (* Be carreful not ot put None here, because if we have n_1 : (s1 = - s2) and then n_2 : (s1.b = 3) the state looks like : - s1.a -> n_1; s1.b -> n_2 ; s1.c -> n_1. And if we - look for s1.a in that state, we get n_1 but this node - represent more that s1.a even if it is so in the - state... ) + ( Be carreful not ot put None here, because if we have n_1 : (s1 = + s2) and then n_2 : (s1.b = 3) the state looks like : + s1.a -> n_1; s1.b -> n_2 ; s1.c -> n_1. And if we + look for s1.a in that state, we get n_1 but this node + represent more that s1.a even if it is so in the + state... *) else Some (Locations.Zone.narrow z loc) in let add n acc = - P.debug ~level:2 "[pdg state] get_loc_nodes -> %a@." + P.debug ~dkey ~level:2 "get_loc_nodes -> %a@." PdgTypes.Node.pretty_with_part (n,z); (n,z)::acc in @@ -132,14 +135,14 @@ (** @raise Cannot_fold (see [get_loc_nodes_and_part]) ) let get_loc_nodes state loc = - P.debug ~level:2 "[pdg state] get_loc_nodes %a@. in %a@." + P.debug ~dkey ~level:2 "get_loc_nodes %a@. in %a@." Locations.Zone.pretty loc pretty state ; if Locations.Zone.equal loc Locations.Zone.bottom then [], None ( nothing to do *) else let nodes = get_loc_nodes_and_part state loc in let undef_zone = Locations.Zone.diff loc state.under_outputs in - P.debug ~level:2 "[pdg state] get_loc_nodes -> undef = %a@." + P.debug ~dkey ~level:2 "get_loc_nodes -> undef = %a@." Locations.Zone.pretty undef_zone; let undef_zone = if (Locations.Zone.equal undef_zone Locations.Zone.bottom) then None diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/pdg_state.mli frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_state.mli --- frama-c-20110201+carbon+dfsg/src/pdg/pdg_state.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/pdg_state.mli 2011-10-10 08:38:30.000000000 +0000 @@ -54,4 +54,3 @@ val get_init_state : t_states -> t val get_stmt_state : t_states -> Cil_types.stmt -> t val get_last_state : t_states -> t - diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/print.ml frama-c-20111001+nitrogen+dfsg/src/pdg/print.ml --- frama-c-20110201+carbon+dfsg/src/pdg/print.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/print.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -(**************************************************************************) -(* ) -( This file is part of Frama-C. ) -( ) -( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( INRIA (Institut National de Recherche en Informatique et en ) -( Automatique) ) -( ) -( you can redistribute it and/or modify it under the terms of the GNU ) -( Lesser General Public License as published by the Free Software ) -( Foundation, version 2.1. ) -( ) -( It 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 Lesser General Public License for more details. ) -( ) -( See the GNU Lesser General Public License version v2.1 ) -( for more details (enclosed in the file licenses/LGPLv2.1). ) -( *) -(**************************************************************************) - -open Cil_types - -module K = PdgIndex.Key -module S = PdgIndex.Signature - -module N = PdgTypes.Node -module G = PdgTypes.G -module Dpd = PdgTypes.Dpd - -let pretty_key = K.pretty - - - - (* - let build_fct_pdg_dot_file proj kf = - let pdg = get_pdg proj kf in - let dot_filename = Pdg.build_dot_file pdg in - Format.printf "[pdg] dot file generated in %s@." dot_filename; - dot_filename - - let show_fct_pdg_dot_file proj kf = - let filename = build_fct_pdg_dot_file proj kf in - let cmd = "zgrviewer -Pdot" in - ignore (Sys.command (cmd^" $PWD/" ^ filename)) -) - -(-----------------------------------------------------------------------*) diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/register.ml frama-c-20111001+nitrogen+dfsg/src/pdg/register.ml --- frama-c-20110201+carbon+dfsg/src/pdg/register.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/register.ml 2011-10-10 08:38:30.000000000 +0000 @@ -31,7 +31,7 @@ let pretty_node short = if short then PdgTypes.Node.pretty - else PdgTypes.Pdg.pretty_node + else PdgTypes.Node.pretty_node let print_dot pdg filename = PdgTypes.Pdg.build_dot filename pdg; @@ -51,8 +51,8 @@ Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.Static.add_codependencies - ~onto:Tbl.self - [ !Db.From.self ]) + ~onto:Tbl.self + [ !Db.From.self ]) (** Register external functions into Db. ) let () = @@ -128,31 +128,39 @@ Ocamlviz.init () ) -let main () = - let force_pdg = - Pdg_parameters.BuildAll.get () - || not (Datatype.String.Set.is_empty (Pdg_parameters.BuildFct.get ())) - in - if force_pdg then begin - Pdg_parameters.feedback "in progress..."; +let output () = + Pdg_parameters.set_debug_keys ["?"]; let do_kf_pdg kf = let fname = Kernel_function.get_name kf in if Pdg_parameters.BuildAll.get () || - Datatype.String.Set.mem fname (Pdg_parameters.BuildFct.get ()) + Datatype.String.Set.mem fname (Pdg_parameters.BuildFct.get ()) then - let pdg = !Db.Pdg.get kf in - let dot_postdom = Pdg_parameters.DotPostdomBasename.get () in - if dot_postdom <> "" then !Db.Postdominators.print_dot dot_postdom kf; + let pdg = !Db.Pdg.get kf in let bw = Pdg_parameters.PrintBw.get () in - Pdg_parameters.result "@[%a@]" (!Db.Pdg.pretty ~bw) pdg; - let dot_basename = Pdg_parameters.DotBasename.get () in - if dot_basename <> "" then + Pdg_parameters.result "@[%a@]" (!Db.Pdg.pretty ~bw) pdg; + let dot_basename = Pdg_parameters.DotBasename.get () in + if dot_basename <> "" then !Db.Pdg.extract pdg (dot_basename ^ "." ^ fname ^ ".dot") in !Db.Semantic_Callgraph.topologically_iter_on_functions do_kf_pdg; + let ks = Pdg_parameters.get_debug_keyset () in + let pp_keys = + Pretty_utils.pp_flowlist ~left:"" ~sep:", " ~right:"." + Format.pp_print_string + in Pdg_parameters.debug ~level:1 "Logging keys : %a" pp_keys ks ; if Pdg_parameters.BuildAll.get () then - Pdg_parameters.feedback "====== PDG GRAPH COMPUTED ======"; - end + Pdg_parameters.feedback "====== PDG GRAPH COMPUTED ======" + +let () = Pdg_parameters.BuildAll.set_output_dependencies + [!Db.Pdg.self; Pdg_parameters.BuildAll.self; Pdg_parameters.BuildFct.self] + +let main () = + let force_pdg = + Pdg_parameters.BuildAll.get () + || not (Datatype.String.Set.is_empty (Pdg_parameters.BuildFct.get ())) + in + if force_pdg then Pdg_parameters.BuildAll.output output + let () = Db.Main.extend main diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/sets.ml frama-c-20111001+nitrogen+dfsg/src/pdg/sets.ml --- frama-c-20110201+carbon+dfsg/src/pdg/sets.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/sets.ml 2011-10-10 08:38:30.000000000 +0000 @@ -26,39 +26,41 @@ open Cil_types -module M = Macros -module P = PdgTypes.Pdg -module D = PdgTypes.Dpd -module N = PdgTypes.Node -module G = PdgTypes.G -module FI = PdgIndex.FctIndex -module K = PdgIndex.Key - -type t_node = PdgTypes.Node.t -type t_loc = Locations.Zone.t -type t_pdg = PdgTypes.Pdg.t -type t_dpds_kind = PdgTypes.Dpd.td -type t_nodes_and_undef = (t_node * t_loc option) list * t_loc option +open PdgTypes +open PdgIndex + +type t_nodes_and_undef = + (Node.t * Locations.Zone.t option) list * Locations.Zone.t option let get_init_state pdg = - try Pdg_state.get_init_state (PdgTypes.Pdg.get_states pdg) + try Pdg_state.get_init_state (Pdg.get_states pdg) with Not_found -> assert false + +(** @raise Not_found when no last state (strange !) ) let get_last_state pdg = - try Pdg_state.get_last_state (PdgTypes.Pdg.get_states pdg) - with Not_found -> raise Db.Pdg.NotFound ( no last state: strange ! *) + Pdg_state.get_last_state (Pdg.get_states pdg) + +(** @raise Not_found for unreachable stmt ) let get_stmt_state pdg stmt = - try Pdg_state.get_stmt_state (PdgTypes.Pdg.get_states pdg) stmt - with Not_found -> raise Db.Pdg.NotFound ( probably an unreachable stmt *) + Pdg_state.get_stmt_state (Pdg.get_states pdg) stmt -let find_node pdg key = FI.find_info (PdgTypes.Pdg.get_index pdg) key +let find_node pdg key = FctIndex.find_info (Pdg.get_index pdg) key (** notice that there can be several nodes if the statement is a call. * For If, Switch, ... the node represent only the condition * (see find_stmt_nodes below). ) let find_simple_stmt_nodes pdg stmt = - let key = K.stmt_key stmt in - FI.find_all (PdgTypes.Pdg.get_index pdg) key + let idx = Pdg.get_index pdg in + let key = Key.stmt_key stmt in + let nodes = FctIndex.find_all idx key in + match stmt.skind with + | Return _ -> ( also add OutRet ) + (try + let ret = FctIndex.find_all idx Key.output_key in + ret @ nodes + with Not_found -> nodes) + | _ -> nodes let rec add_stmt_nodes pdg nodes s = let s_nodes = find_simple_stmt_nodes pdg s in @@ -69,11 +71,11 @@ match s.skind with | Switch (_,blk,_,_) | Loop (_, blk, _, _, _) | Block blk -> Pdg_parameters.debug ~level:2 - " select_stmt_computation on composed stmt %d@." s.sid; + " select_stmt_computation on composed stmt %d@." s.sid; add_block_stmts_nodes nodes blk | UnspecifiedSequence seq -> Pdg_parameters.debug ~level:2 - " select_stmt_computation on composed stmt %d@." s.sid; + " select_stmt_computation on composed stmt %d@." s.sid; add_block_stmts_nodes nodes (Cil.block_from_unspecified_sequence seq) | If (_,bthen,belse,_) -> let nodes = add_block_stmts_nodes nodes bthen in @@ -87,19 +89,13 @@ let find_stmt_and_blocks_nodes pdg stmt = add_stmt_nodes pdg [] stmt -let find_stmt_node pdg stmt = - let key = K.stmt_key stmt in find_node pdg key +let find_stmt_node pdg stmt = find_node pdg (Key.stmt_key stmt) let find_entry_point_node pdg = - try - let key = K.entry_point in - find_node pdg key - with PdgIndex.NotFound -> - assert false - -let find_top_input_node pdg = - let key = K.top_input in find_node pdg key + try find_node pdg Key.entry_point + with Not_found -> assert false +let find_top_input_node pdg = find_node pdg Key.top_input let find_loc_nodes pdg state loc = let nodes, undef = Pdg_state.get_loc_nodes state loc in @@ -111,7 +107,7 @@ | Locations.Zone.Top(_,_) -> begin try (find_top_input_node pdg, None)::init_nodes - with PdgIndex.NotFound -> init_nodes + with Not_found -> init_nodes end | _ -> init_nodes in @@ -141,7 +137,7 @@ else match stmt.skind, stmt.succs with | Return _, [] -> get_nodes (get_last_state pdg) | _, [] -> ( no successors but not a return => unreachable ) - raise PdgIndex.NotFound + raise Not_found | _, succs -> get_stmts_nodes succs in nodes, undef_zone @@ -153,10 +149,10 @@ init_state only contains implicit inputs * while begin contains only formal arguments *) let find_location_nodes_at_begin pdg loc = - let kf = M.get_pdg_kf pdg in + let kf = Pdg.get_kf pdg in let stmts = - try let f = Kernel_function.get_definition kf in f.sbody.bstmts - with Kernel_function.No_Definition -> [] + if !Db.Value.use_spec_instead_of_definition kf then [] + else let f = Kernel_function.get_definition kf in f.sbody.bstmts in let state = match stmts with | [] -> get_last_state pdg @@ -165,23 +161,18 @@ find_loc_nodes pdg state loc let find_label_node pdg label_stmt label = - let key = K.label_key label_stmt label in - find_node pdg key + find_node pdg (Key.label_key label_stmt label) -let find_decl_var_node pdg v = - let key = K.decl_var_key v in - find_node pdg key +let find_decl_var_node pdg v = find_node pdg (Key.decl_var_key v) -let find_output_node pdg = - let key = K.output_key in - find_node pdg key +let find_output_node pdg = find_node pdg Key.output_key let find_input_node pdg numin = - let sgn = FI.sgn (PdgTypes.Pdg.get_index pdg) in + let sgn = FctIndex.sgn (Pdg.get_index pdg) in PdgIndex.Signature.find_input sgn numin let find_all_input_nodes pdg = - let sgn = FI.sgn (PdgTypes.Pdg.get_index pdg) in + let sgn = FctIndex.sgn (Pdg.get_index pdg) in let add acc (_in_key, info) = info::acc in PdgIndex.Signature.fold_all_inputs add [] sgn @@ -189,24 +180,24 @@ match in_key with | PdgIndex.Signature.InCtrl | PdgIndex.Signature.InNum _ -> - let idx = PdgTypes.Pdg.get_index pdg_caller in - let _, call_sgn = FI.find_call idx call_stmt in + let idx = Pdg.get_index pdg_caller in + let _, call_sgn = FctIndex.find_call idx call_stmt in let node = PdgIndex.Signature.find_in_info call_sgn in_key in [ node, None ], None | PdgIndex.Signature.InImpl zone -> find_location_nodes_at_stmt pdg_caller call_stmt ~before:true zone let find_call_ctrl_node pdg stmt = - let key = K.call_ctrl_key stmt in + let key = Key.call_ctrl_key stmt in find_node pdg key let find_call_num_input_node pdg call num_in = if num_in = 0 then Pdg_parameters.fatal "0 is not an input number" ; - let key = K.call_input_key call num_in in + let key = Key.call_input_key call num_in in find_node pdg key let find_call_output_node pdg call = - let key = K.call_outret_key call in + let key = Key.call_outret_key call in find_node pdg key let find_output_nodes called_pdg out_key = @@ -241,7 +232,7 @@ (** add the node in the list if it is not already in. ) let add_node_in_list node node_list = let is_node_in node node_list = - let is_node n = (N.compare node n) = 0 in + let is_node n = (Node.compare node n) = 0 in try let _ = List.find is_node node_list in true with Not_found -> false in @@ -256,9 +247,9 @@ let node_list, added = add_node_in_list node node_list in if added then - let is_block = match N.elem_key node with - | K.SigKey (PdgIndex.Signature.In PdgIndex.Signature.InCtrl) -> true - | K.Stmt stmt -> + let is_block = match Node.elem_key node with + | Key.SigKey (PdgIndex.Signature.In PdgIndex.Signature.InCtrl) -> true + | Key.Stmt stmt -> (match stmt.skind with Block _ | UnspecifiedSequence _ -> true | _ -> false) @@ -268,7 +259,7 @@ then node_list ( blocks are not relevant to propagate information *) else List.fold_left - (add_node_and_custom_dpds get_dpds) node_list (get_dpds node) + (add_node_and_custom_dpds get_dpds) node_list (get_dpds node) else node_list let add_nodes_and_custom_dpds get_dpds node_list nodes = @@ -281,22 +272,22 @@ let filter_nodes l = List.map (fun (n,_) -> n) l let get_both_dpds pdg n = - filter_nodes (P.get_all_direct_codpds pdg n @ P.get_all_direct_dpds pdg n) + filter_nodes (Pdg.get_all_direct_codpds pdg n @ Pdg.get_all_direct_dpds pdg n) (** {3 Backward} build sets of the dependencies of given nodes *) (** gives the list of nodes that the given node depends on, without looking at the kind of dependency. *) -let direct_dpds pdg node = filter_nodes (P.get_all_direct_dpds pdg node) +let direct_dpds pdg node = filter_nodes (Pdg.get_all_direct_dpds pdg node) (** gives the list of nodes that the given node depends on, with a given kind of dependency. *) let direct_x_dpds dpd_type pdg node = - filter_nodes (P.get_x_direct_dpds dpd_type pdg node) + filter_nodes (Pdg.get_x_direct_dpds dpd_type pdg node) -let direct_data_dpds = direct_x_dpds D.Data -let direct_ctrl_dpds = direct_x_dpds D.Ctrl -let direct_addr_dpds = direct_x_dpds D.Addr +let direct_data_dpds = direct_x_dpds Dpd.Data +let direct_ctrl_dpds = direct_x_dpds Dpd.Ctrl +let direct_addr_dpds = direct_x_dpds Dpd.Addr (** accumulates in [node_list] the results of [add_node_and_dpds_or_codpds] for all the [nodes] *) @@ -323,34 +314,37 @@ in List.fold_left merge_dpds [] nodes -let find_nodes_all_data_dpds = find_nodes_all_x_dpds D.Data -let find_nodes_all_ctrl_dpds = find_nodes_all_x_dpds D.Ctrl -let find_nodes_all_addr_dpds = find_nodes_all_x_dpds D.Addr +let find_nodes_all_data_dpds = find_nodes_all_x_dpds Dpd.Data +let find_nodes_all_ctrl_dpds = find_nodes_all_x_dpds Dpd.Ctrl +let find_nodes_all_addr_dpds = find_nodes_all_x_dpds Dpd.Addr (** {3 Forward} build sets of the nodes that depend on given nodes *) (** @return the list of nodes that directly depend on the given node *) -let direct_uses pdg node = filter_nodes (P.get_all_direct_codpds pdg node) +let direct_uses pdg node = filter_nodes (Pdg.get_all_direct_codpds pdg node) let direct_x_uses dpd_type pdg node = - filter_nodes (P.get_x_direct_codpds dpd_type pdg node) + filter_nodes (Pdg.get_x_direct_codpds dpd_type pdg node) -let direct_data_uses = direct_x_uses D.Data -let direct_ctrl_uses = direct_x_uses D.Ctrl -let direct_addr_uses = direct_x_uses D.Addr +let direct_data_uses = direct_x_uses Dpd.Data +let direct_ctrl_uses = direct_x_uses Dpd.Ctrl +let direct_addr_uses = direct_x_uses Dpd.Addr (** @return a list containing all the nodes that depend on the given nodes. *) let all_uses pdg nodes = let add_codpds node_list node = - let codpds = P.get_all_direct_codpds pdg node in + let codpds = Pdg.get_all_direct_codpds pdg node in let codpds = filter_nodes codpds in - let get n = filter_nodes (P.get_all_direct_codpds pdg n) in + let get n = filter_nodes (Pdg.get_all_direct_codpds pdg n) in add_nodes_and_custom_dpds get node_list codpds in List.fold_left add_codpds [] nodes (** {3 Others} *) +let node_set_of_list l = + List.fold_left (fun acc n -> NodeSet.add n acc) NodeSet.empty l + (** build a list of all the nodes that are related 'somehow' to the given nodes. It is a kind of transitive closure of [all_uses] U [all_dpds]. ) let all_related_nodes pdg nodes = @@ -366,22 +360,21 @@ "[pdg:find_call_out_nodes_to_select] for call sid:%d@." call_stmt.sid; let _, call_sgn = - FI.find_call (PdgTypes.Pdg.get_index pdg_caller) call_stmt + FctIndex.find_call (Pdg.get_index pdg_caller) call_stmt in - let called_selected_nodes_set = - PdgTypes.NodeSet.add_list called_selected_nodes in + let called_selected_nodes_set = node_set_of_list called_selected_nodes in let test_out acc (out_key, call_out_node) = let called_out_nodes, _undef = find_output_nodes pdg_called out_key in ( undef can be ignored in this case because it is taken into account in * the call part. ) let intersect = List.exists - (fun (n,_z) -> PdgTypes.NodeSet.mem n called_selected_nodes_set) + (fun (n,_z) -> NodeSet.mem n called_selected_nodes_set) called_out_nodes in if intersect then begin Pdg_parameters.debug ~level:2 - "\t+ n_%a@." Macros.pretty_node call_out_node; + "\t+ %a@." Node.pretty call_out_node; call_out_node::acc end else acc @@ -393,9 +386,8 @@ Pdg_parameters.debug ~level:2 "[pdg:find_in_nodes_to_select_for_this_call] for call sid:%d@." call_stmt.sid; - let sgn = FI.sgn (PdgTypes.Pdg.get_index pdg_called) in - let caller_selected_nodes_set = - PdgTypes.NodeSet.add_list caller_selected_nodes in + let sgn = FctIndex.sgn (Pdg.get_index pdg_called) in + let caller_selected_nodes_set = node_set_of_list caller_selected_nodes in let test_in acc (in_key, in_node) = let caller_nodes, _undef = find_call_input_nodes pdg_caller call_stmt in_key in @@ -403,11 +395,12 @@ the call part. *) let intersect = List.exists - (fun (n,_z) -> PdgTypes.NodeSet.mem n caller_selected_nodes_set) + (fun (n,_z) -> NodeSet.mem n caller_selected_nodes_set) caller_nodes in if intersect then begin - Pdg_parameters.debug ~level:2 "\t+ n_%a@." Macros.pretty_node in_node; + Pdg_parameters.debug ~level:2 "\t+ %a@." + Node.pretty in_node; in_node::acc end else acc diff -Nru frama-c-20110201+carbon+dfsg/src/pdg/sets.mli frama-c-20111001+nitrogen+dfsg/src/pdg/sets.mli --- frama-c-20110201+carbon+dfsg/src/pdg/sets.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg/sets.mli 2011-10-10 08:38:30.000000000 +0000 @@ -24,75 +24,72 @@ (** PDG (program dependence graph) access functions. ) -type t_node = PdgTypes.Node.t -type t_loc = Locations.Zone.t -type t_pdg = PdgTypes.Pdg.t -type t_dpds_kind = PdgTypes.Dpd.td +open PdgTypes -type t_nodes_and_undef = (t_node t_loc option) list * t_loc option +type t_nodes_and_undef = + (Node.t * Locations.Zone.t option) list * Locations.Zone.t option (** {2 PDG nodes for some elements} ) -val find_stmt_node : t_pdg -> Cil_types.stmt -> t_node -val find_simple_stmt_nodes : t_pdg -> Cil_types.stmt -> t_node list -val find_stmt_and_blocks_nodes : t_pdg -> Cil_types.stmt -> t_node list -(val find_nodes_for_stmt_id : t_pdg -> int -> t_node list) -val find_location_nodes_at_stmt : - t_pdg -> Cil_types.stmt -> before:bool -> t_loc -> t_nodes_and_undef -val find_location_nodes_at_end : t_pdg -> t_loc -> t_nodes_and_undef -val find_location_nodes_at_begin : t_pdg -> t_loc -> t_nodes_and_undef -val find_label_node : t_pdg -> Cil_types.stmt -> Cil_types.label -> t_node -val find_decl_var_node : t_pdg -> Cil_types.varinfo -> t_node -val find_input_node : t_pdg -> int -> t_node -val find_output_node : t_pdg -> t_node -val find_all_input_nodes : t_pdg -> t_node list -val find_entry_point_node : t_pdg -> t_node -val find_top_input_node : t_pdg -> t_node +val find_stmt_node : Pdg.t -> Cil_types.stmt -> Node.t +val find_simple_stmt_nodes : Pdg.t -> Cil_types.stmt -> Node.t list +val find_stmt_and_blocks_nodes : Pdg.t -> Cil_types.stmt -> Node.t list +(val find_nodes_for_stmt_id : Pdg.t -> int -> Node.t list) +val find_location_nodes_at_stmt : Pdg.t -> Cil_types.stmt -> before:bool -> + Locations.Zone.t -> t_nodes_and_undef +val find_location_nodes_at_end : + Pdg.t -> Locations.Zone.t -> t_nodes_and_undef +val find_location_nodes_at_begin : + Pdg.t -> Locations.Zone.t -> t_nodes_and_undef +val find_label_node : Pdg.t -> Cil_types.stmt -> Cil_types.label -> Node.t +val find_decl_var_node : Pdg.t -> Cil_types.varinfo -> Node.t +val find_input_node : Pdg.t -> int -> Node.t +val find_output_node : Pdg.t -> Node.t +val find_all_input_nodes : Pdg.t -> Node.t list +val find_entry_point_node : Pdg.t -> Node.t +val find_top_input_node : Pdg.t -> Node.t val find_output_nodes : - t_pdg -> PdgIndex.Signature.t_out_key -> t_nodes_and_undef + Pdg.t -> PdgIndex.Signature.t_out_key -> t_nodes_and_undef -val find_call_ctrl_node : t_pdg -> Cil_types.stmt -> t_node -val find_call_num_input_node : t_pdg -> Cil_types.stmt -> int -> t_node +val find_call_ctrl_node : Pdg.t -> Cil_types.stmt -> Node.t +val find_call_num_input_node : Pdg.t -> Cil_types.stmt -> int -> Node.t val find_call_input_nodes : - t_pdg -> Cil_types.stmt -> PdgIndex.Signature.t_in_key -> t_nodes_and_undef -val find_call_output_node : t_pdg -> Cil_types.stmt -> t_node + Pdg.t -> Cil_types.stmt -> PdgIndex.Signature.t_in_key -> t_nodes_and_undef +val find_call_output_node : Pdg.t -> Cil_types.stmt -> Node.t val find_call_stmts: - Db_types.kernel_function -> caller:Db_types.kernel_function -> + Cil_types.kernel_function -> caller:Cil_types.kernel_function -> Cil_types.stmt list val find_call_out_nodes_to_select : - t_pdg -> t_node list -> t_pdg -> Cil_types.stmt -> t_node list + Pdg.t -> Node.t list -> Pdg.t -> Cil_types.stmt -> Node.t list val find_in_nodes_to_select_for_this_call : - t_pdg -> t_node list -> Cil_types.stmt -> t_pdg -> t_node list + Pdg.t -> Node.t list -> Cil_types.stmt -> Pdg.t -> Node.t list ( direct dependencies only : * This means the nodes that have an edge to the given node. ) -val direct_dpds : t_pdg -> t_node -> t_node list -val direct_x_dpds : t_dpds_kind -> t_pdg -> t_node -> t_node list -val direct_data_dpds : t_pdg -> t_node -> t_node list -val direct_ctrl_dpds : t_pdg -> t_node -> t_node list -val direct_addr_dpds : t_pdg -> t_node -> t_node list +val direct_dpds : Pdg.t -> Node.t -> Node.t list +val direct_data_dpds : Pdg.t -> Node.t -> Node.t list +val direct_ctrl_dpds : Pdg.t -> Node.t -> Node.t list +val direct_addr_dpds : Pdg.t -> Node.t -> Node.t list ( transitive closure ) -val find_nodes_all_dpds : t_pdg -> t_node list -> t_node list -val find_nodes_all_x_dpds : t_dpds_kind -> t_pdg -> t_node list -> t_node list -val find_nodes_all_data_dpds : t_pdg -> t_node list -> t_node list -val find_nodes_all_ctrl_dpds : t_pdg -> t_node list -> t_node list -val find_nodes_all_addr_dpds : t_pdg -> t_node list -> t_node list +val find_nodes_all_dpds : Pdg.t -> Node.t list -> Node.t list +val find_nodes_all_data_dpds : Pdg.t -> Node.t list -> Node.t list +val find_nodes_all_ctrl_dpds : Pdg.t -> Node.t list -> Node.t list +val find_nodes_all_addr_dpds : Pdg.t -> Node.t list -> Node.t list ( forward ) -val direct_uses : t_pdg -> t_node -> t_node list -val direct_x_uses : t_dpds_kind -> t_pdg -> t_node -> t_node list -val direct_data_uses : t_pdg -> t_node -> t_node list -val direct_ctrl_uses : t_pdg -> t_node -> t_node list -val direct_addr_uses : t_pdg -> t_node -> t_node list +val direct_uses : Pdg.t -> Node.t -> Node.t list +val direct_data_uses : Pdg.t -> Node.t -> Node.t list +val direct_ctrl_uses : Pdg.t -> Node.t -> Node.t list +val direct_addr_uses : Pdg.t -> Node.t -> Node.t list -val all_uses : t_pdg -> t_node list -> t_node list +val all_uses : Pdg.t -> Node.t list -> Node.t list ( others ) -val custom_related_nodes : (t_node -> t_node list) -> t_node list -> t_node list +val custom_related_nodes : (Node.t -> Node.t list) -> Node.t list -> Node.t list diff -Nru frama-c-20110201+carbon+dfsg/src/pdg_types/pdgIndex.ml frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgIndex.ml --- frama-c-20110201+carbon+dfsg/src/pdg_types/pdgIndex.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgIndex.ml 2011-10-10 08:38:28.000000000 +0000 @@ -31,7 +31,6 @@ exception AddError exception CallStatement exception Not_equal -exception NotFound let is_call_stmt stmt = match stmt.skind with Instr (Call _) -> true | _ -> false @@ -44,9 +43,9 @@ type 'info t = { in_ctrl : 'info option ; in_params : (int 'info) list ; - (** implicit inputs : - Maybe we should use [Lmap_bitwise.Make_bitwise] ? - but that would make things a lot more complicated... :-? *) + (** implicit inputs : + Maybe we should use [Lmap_bitwise.Make_bitwise] ? + but that would make things a lot more complicated... :-? ) in_implicits : (Locations.Zone.t 'info) list ; out_ret : 'info option ; outputs : (Locations.Zone.t * 'info) list } @@ -57,6 +56,16 @@ Structure (Sum [| [| p_int |]; [| Locations.Zone.packed_descr |] |]) let out_key = Structure (Sum [| [| Locations.Zone.packed_descr |] |]) let key = Structure (Sum [| [| pack in_key |]; [| pack out_key |] |]) + + let t d_info = t_record + [| pack (t_option d_info); + pack (t_list (t_tuple [| p_int; pack d_info |])); + pack (t_list (t_tuple [| Locations.Zone.packed_descr; + pack d_info |])); + pack (t_option d_info); + pack (t_list (t_tuple [| Locations.Zone.packed_descr; + pack d_info |])); + |] end let empty = { in_ctrl = None ; @@ -176,11 +185,11 @@ assert (n <> 0); (* no input 0 : use find_in_ctrl *) List.assoc n sgn.in_params with Not_found -> - raise NotFound + raise Not_found let find_output sgn out_key = let rec find l = match l with - | [] -> raise NotFound + | [] -> raise Not_found | (loc, e)::tl -> if Locations.Zone.equal out_key loc then e else find tl @@ -189,17 +198,17 @@ let find_out_ret sgn = match sgn.out_ret with | Some i -> i - | None -> raise NotFound + | None -> raise Not_found let find_in_ctrl sgn = match sgn.in_ctrl with | Some i -> i - | None -> raise NotFound + | None -> raise Not_found (** try to find an exact match with loc. * we shouldn't try to find a zone that we don't have... ) let find_implicit_input sgn loc = let rec find l = match l with - | [] -> raise NotFound + | [] -> raise Not_found | (in_loc, e)::tl -> if Locations.Zone.equal in_loc loc then e else find tl @@ -282,7 +291,7 @@ | (InNum n) -> Format.fprintf fmt "In%d" n | InCtrl -> Format.fprintf fmt "InCtrl" | InImpl loc -> - Format.fprintf fmt "@[<h 1>In(%a)@]" Locations.Zone.pretty loc + Format.fprintf fmt "@[<h 1>In(%a)@]" Locations.Zone.pretty loc let pretty_out_key fmt key = match key with | OutRet -> Format.fprintf fmt "OutRet" @@ -300,8 +309,7 @@ module Key = struct type t_call_id = Cil_types.stmt - - ( type annot_key = Cil_types.code_annotation ) + let t_call_id_packed_descr = Cil_datatype.Stmt.packed_descr type key = | SigKey of Signature.t_key @@ -317,12 +325,10 @@ | SigCallKey of t_call_id Signature.t_key (** Key for an element of a call (input or output). * The call is identified by the statement. ) - ( | Annot of annot_key - * annotation identified by its kind and id ) let entry_point = SigKey (Signature.in_ctrl_key) let top_input = SigKey (Signature.in_top_key) - let param_key num_in _param = SigKey (Signature.in_key num_in) + let param_key num_in = SigKey (Signature.in_key num_in) let implicit_in_key loc = SigKey (Signature.in_impl_key loc) let output_key = SigKey (Signature.out_ret_key) @@ -343,11 +349,6 @@ let call_from_id call_id = call_id - ( let code_annot_key annot = Annot (annot) ) - - ( let cmp_annots (a1: annot_key) (a2: annot_key) = - compare a1.annot_id a2.annot_id ) - let stmt key = match key with | SigCallKey (call, _) -> Some call @@ -376,124 +377,111 @@ | CallStmt call -> let call = call_from_id call in Format.fprintf fmt "Call%d : %a" call.sid print_stmt call - | Stmt s -> - print_stmt fmt s - | Label (_,l) -> - Format.fprintf fmt "%a" !Ast_printer.d_label l - | VarDecl v -> - Format.fprintf fmt "VarDecl : %a" !Ast_printer.d_ident v.vname - | SigKey k -> - Format.fprintf fmt "%a" Signature.pretty_key k + | Stmt s -> print_stmt fmt s + | Label (_,l) -> Format.fprintf fmt "%a" !Ast_printer.d_label l + | VarDecl v -> Format.fprintf fmt "VarDecl : %a" !Ast_printer.d_var v + | SigKey k -> Format.fprintf fmt "%a" Signature.pretty_key k | SigCallKey (call, sgn) -> let call = call_from_id call in Format.fprintf fmt "Call%d-%a : %a" call.sid Signature.pretty_key sgn print_stmt call - ( | Annot annot -> - Format.fprintf fmt "CodeAnnot-%d : %a@\n" - annot.annot_id - !Ast_printer.d_code_annotation annot ) include Datatype.Make - (struct - include Datatype.Serializable_undefined - type t = key - let name = "PdgIndex.Key" - open Cil_datatype - let reprs = - List.fold_left - (fun acc v -> - List.fold_left - (fun acc s -> Stmt s :: acc) - (VarDecl v :: acc) - (Type.reprs Stmt.ty)) - [] - (Type.reprs Varinfo.ty) - open Structural_descr - let structural_descr = - let p_key = pack Signature.Str_descr.key in - Structure - (Sum - [| - [| p_key |]; - [| Varinfo.packed_descr |]; - [| Stmt.packed_descr |]; - [| Stmt.packed_descr |]; - [| p_int; Label.packed_descr |]; - [| Stmt.packed_descr; p_key |]; - |]) - let rehash = Datatype.identity - let pretty = pretty_node - let mem_project = Datatype.never_any_project - end) + (struct + include Datatype.Serializable_undefined + type t = key + let name = "PdgIndex.Key" + open Cil_datatype + let reprs = + List.fold_left + (fun acc v -> + List.fold_left + (fun acc s -> Stmt s :: acc) + (VarDecl v :: acc) + Stmt.reprs) + [] + Varinfo.reprs + open Structural_descr + let structural_descr = + let p_key = pack Signature.Str_descr.key in + Structure + (Sum + [| + [| p_key |]; + [| Varinfo.packed_descr |]; + [| Stmt.packed_descr |]; + [| t_call_id_packed_descr |]; + [| p_int; Label.packed_descr |]; + [| t_call_id_packed_descr; p_key |]; + |]) + let rehash = Datatype.identity + let pretty = pretty_node + let mem_project = Datatype.never_any_project + end) end +module Hkey = struct + type tt = Hdecl of Cil_types.varinfo + | Hstmt of int | Hlabel of int Cil_types.label + let hkey k = + match k with + | Key.Stmt stmt -> Hstmt stmt.sid + | Key.VarDecl var -> Hdecl var + | Key.Label (sid,l) -> Hlabel (sid,l) + | _ -> assert false + + let key hk = match hk with + | Hdecl v -> Key.VarDecl v + | Hstmt sid -> Key.Stmt (fst (Kernel_function.find_from_sid sid)) + | Hlabel (sid,l) -> Key.Label (sid,l) -module FctIndex : sig - type ('a, 'b) t - - val create : int -> ('a, 'b) t - val length : ('a, 'b) t -> int - - val copy : ('a, 'b) t -> ('a, 'b) t - val merge : ('a, 'b) t -> ('a, 'b) t -> - ('a -> 'a -> 'a) -> ('b -> 'b -> 'b) -> - ('a, 'b) t - - val sgn : ('a, 'b) t -> 'a Signature.t - val find_info : ('a, 'b) t -> Key.t-> 'a - val find_all : ('a, 'b) t -> Key.t-> 'a list - - val find_call : ('a, 'b) t -> Cil_types.stmt -> 'b option * 'a Signature.t - val find_call_key : ('a, 'b) t -> Key.t -> 'b option * 'a Signature.t - - val find_info_call : ('a, 'b) t -> Cil_types.stmt -> 'b - val find_info_call_key : ('a, 'b) t -> Key.t -> 'b - - val fold_calls : (Key.t_call_id-> 'b option * 'a Signature.t -> 'c -> 'c) -> - ('a, 'b) t -> 'c -> 'c - - val add : ('a, 'b) t -> Key.t-> 'a -> unit - val add_or_replace : ('a, 'b) t -> Key.t-> 'a -> unit - val add_info_call : ('a, 'b) t -> Key.t_call_id -> 'b -> replace:bool -> unit - val add_info_call_key : ('a, 'b) t -> Key.t -> 'b -> replace:bool -> unit - -end = struct - - module Hkey = struct - type t = Hdecl of Cil_types.varinfo - | Hstmt of int | Hlabel of int * Cil_types.label + include Datatype.Make(struct + include Datatype.Serializable_undefined let hash k = let code n c = assert (c < 4) ; n4 + c in match k with - | Hdecl v -> code v.vid 1 - | Hstmt n -> code n 2 - | Hlabel (n,_) -> code n 3 + | Hdecl v -> code v.vid 1 + | Hstmt n -> code n 2 + | Hlabel (n,_) -> code n 3 let equal k1 k2 = (hash k1) = (hash k2) + ( TODO: write better function, or check that the computation of the hash + does not overflow *) + type t = tt + let reprs = [Hstmt (-1)] + let name = "PdgIndex.Hkey.t" + end) +end - let hkey k = - match k with - | Key.Stmt stmt -> Hstmt stmt.sid - | Key.VarDecl var -> Hdecl var - | Key.Label (sid,l) -> Hlabel (sid,l) - | _ -> assert false - end - - module H = Hashtbl.Make(Hkey) +module H = Hashtbl.Make(Hkey) - type ('a,'b) t = { +module FctIndex = struct + + type ('node_info, 'call_info) t = { (** inputs and ouputs of the function *) - mutable sgn : 'a Signature.t ; + mutable sgn : 'node_info Signature.t ; (** calls signatures ) - mutable calls : (Key.t_call_id ('b option * 'a Signature.t)) list ; + mutable calls : + (Key.t_call_id * ('call_info option * 'node_info Signature.t)) list ; (** everything else ) - other : 'a H.t + other : 'node_info H.t } - let hkey = Hkey.hkey + open Structural_descr + let t_descr ~ni:d_ninfo ~ci:d_cinfo = + t_record + [| pack (Signature.Str_descr.t d_ninfo); + pack (t_list (t_tuple [| Key.t_call_id_packed_descr; + pack (t_tuple [| + pack (t_option d_cinfo); + pack (Signature.Str_descr.t d_ninfo); + |]) + |])); + pack (t_hashtbl_unchanged_hashs (Descr.str Hkey.descr) d_ninfo); + |] let sgn idx = idx.sgn @@ -524,19 +512,6 @@ else c2 :: (merge l1 tl2) in merge calls1 calls2 - ( let merge_annots l1 l2 merge_info = - let rec merge l1 l2 = match l1, l2 with - | [], _ -> l2 - | _, [] -> l1 - | (k1, i1)::tl1, (k2, i2)::tl2 -> - let cmp = Key.cmp_annots k1 k2 in - if cmp = 0 then - let info = merge_info i1 i2 in - (k1, info) :: (merge tl1 tl2) - else if cmp < 0 then (k1, i1) :: (merge tl1 l2) - else (k2,i2) :: (merge l1 tl2) - in merge l1 l2 ) - let merge idx1 idx2 merge_a merge_b = let sgn = Signature.merge idx1.sgn idx2.sgn merge_a in let table = H.copy idx1.other in @@ -547,7 +522,6 @@ in H.replace table k a in H.iter add idx2.other; let calls = merge_info_calls idx1.calls idx2.calls merge_a merge_b in - ( let annots = merge_annots idx1.annots idx2.annots merge_a in ) {sgn = sgn; calls = calls; other = table} let add_info_call idx call e ~replace = @@ -582,31 +556,14 @@ else (c1 :: (add tl)) in add calls - ( let rec add_info_annot annots k e replace = match annots with - | [] -> (k, e)::[] - | (ka, ea)::tl -> - let cmp = Key.cmp_annots k ka in - if cmp = 0 then - (if replace then (k, e)::tl else raise AddError) - else if cmp < 0 then - (k,e)::annots - else (ka, ea)::(add_info_annot tl k e replace) - - let rec find_info_annot annots k = match annots with - | [] -> raise NotFound - | (ka, ea)::tl -> - if (Key.cmp_annots k ka) = 0 then ea - else find_info_annot tl k - ) - let find_call idx call = let rec find l = match l with - | [] -> raise NotFound + | [] -> raise Not_found | (call1, e1) :: tl -> let sid = call.sid in let sid1 = call1.sid in if sid = sid1 then e1 - else if sid < sid1 then raise NotFound + else if sid < sid1 then raise Not_found else find tl in find idx.calls @@ -621,7 +578,7 @@ let find_info_call idx call = let (e1, _sgn1) = find_call idx call in - match e1 with Some e -> e | None -> raise NotFound + match e1 with Some e -> e | None -> raise Not_found let find_info_call_key idx key = match key with @@ -645,31 +602,22 @@ | Key.SigCallKey (call, k) -> idx.calls <- add_info_sig_call idx.calls call k e replace | Key.VarDecl _ | Key.Stmt _ | Key.Label _ -> - hfct idx.other (hkey key) e - ( | Key.Annot k -> - idx.annots <- add_info_annot idx.annots k e replace ) + hfct idx.other (Hkey.hkey key) e let add idx key e = add_replace idx key e false let add_or_replace idx key e = add_replace idx key e true - ( let remove idx key = match key with - | Key.Annot ak -> - idx.annots <- - List.filter (fun (k,_) -> Key.cmp_annots k ak <> 0) idx.annots - | _ -> (* TODO is needed... ) assert false ) - let length idx = H.length idx.other - let find_info idx key = match key with | Key.SigKey k -> Signature.find_info idx.sgn k | Key.CallStmt _ -> raise CallStatement (* see find_info_call ) | Key.SigCallKey (call, k) -> find_info_sig_call idx call k | Key.VarDecl _ | Key.Stmt _ | Key.Label _ -> - (try H.find idx.other (hkey key) with Not_found -> raise NotFound) - ( | Key.Annot k -> find_info_annot idx.annots k *) + (try H.find idx.other (Hkey.hkey key) + with Not_found -> raise Not_found) let find_all idx key = match key with @@ -679,19 +627,32 @@ (** Similar to [find_info] for a label ) let find_label idx lab = let collect k info res = match k with - | Hkey.Hlabel (_,k_lab) -> if k_lab = lab then info :: res else res + | Hkey.Hlabel (_,k_lab) -> + if Cil_datatype.Label.equal k_lab lab then info :: res else res | _ -> res in let infos = H.fold collect idx.other [] in match infos with - info :: [] -> info | [] -> raise NotFound | _ -> assert false + info :: [] -> info | [] -> raise Not_found | _ -> assert false let fold_calls f idx acc = - let process acc (call, (i, sgn)) = f call (i, sgn) acc in + let process acc (call, (_i, _sgn as i_sgn)) = f call i_sgn acc in List.fold_left process acc idx.calls -( let fold_implicit_inputs f acc idx = - Signature.fold_impl_inputs f acc idx.sgn ) + let fold f idx acc = + let acc = Signature.fold + (fun acc (k, info) -> f (Key.SigKey k) info acc) + acc idx.sgn in + let acc = H.fold + (fun k info acc -> f (Hkey.key k) info acc) idx.other acc in + List.fold_left + (fun acc (call, (_, sgn)) -> + Signature.fold (fun acc (k, info) -> + f (Key.SigCallKey (call, k)) info acc) + acc sgn) + acc idx.calls + + end ( diff -Nru frama-c-20110201+carbon+dfsg/src/pdg_types/pdgIndex.mli frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgIndex.mli --- frama-c-20110201+carbon+dfsg/src/pdg_types/pdgIndex.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgIndex.mli 2011-10-10 08:38:28.000000000 +0000 @@ -43,9 +43,6 @@ * information has a different type. *) exception CallStatement -(** When we try to find an element that is not in the index *) -exception NotFound - (** When we compare two things with different locations (no order) *) exception Not_equal @@ -114,7 +111,7 @@ module Key : sig (** type to identify a call statement ) - type t_call_id + type t_call_id = Cil_types.stmt type key = private @@ -129,9 +126,7 @@ include Datatype.S with type t = key - ( [VP 2011-02-02] What is exactly the purpose of this unused parameter 'a? - *) - val param_key : int -> 'a -> t + val param_key : int -> t val implicit_in_key : Locations.Zone.t -> t val entry_point : t val top_input : t @@ -155,6 +150,7 @@ end + (** Mapping between the function elements we are interested in and some * information. Used for instance to associate the nodes with the statements, * or the marks in a slice. @@ -163,58 +159,66 @@ (** this type is used to build indexes between program objects and some information such as the PDG nodes or the slicing marks. - - ['a] if the type of the information to store for each element, - - ['b] if the type of the information that can be attached to call - statements (calls are themselves composed of several elements, so ['a] - information stored for each of them (['a Signature.t])) ) - type ('a, 'b) t + - ['ni] if the type of the information to store for each element, + - ['ci] if the type of the information that can be attached to call + statements (calls are themselves composed of several elements, so ['ni] + information stored for each of them (['ni Signature.t])) ) + type ('ni, 'ci) t - val create: int -> ('a, 'b) t - val length: ('a, 'b) t -> int + val create : int -> ('ni, 'ci) t + val length : ('ni, 'ci) t -> int (** just copy the mapping *) - val copy: ('a, 'b) t -> ('a, 'b) t + val copy : ('ni, 'ci) t -> ('ni, 'ci) t (** merge the two indexes using given functions [merge_a] and [merge_b]. These function are _not_ called when an element is in one index, but not the other. It is assumed that [merge_x x bot = x]. *) - val merge: ('a, 'b) t -> ('a, 'b) t -> - ('a -> 'a -> 'a) -> ('b -> 'b -> 'b) -> - ('a, 'b) t + val merge : ('ni, 'ci) t -> ('ni, 'ci) t -> + ('ni -> 'ni -> 'ni) -> + ('ci -> 'ci -> 'ci) -> + ('ni, 'ci) t (** get the information stored for the function signature *) - val sgn: ('a, 'b) t -> 'a Signature.t + val sgn : ('ni, 'ci) t -> 'ni Signature.t (** find the information stored for the key. Cannot be used for [Key.CallStmt] keys because the type of the stored information is not the same. See [find_call] instead. *) - val find_info: ('a, 'b) t -> Key.t -> 'a + val find_info : ('ni, 'ci) t -> Key.t-> 'ni (** same than [find_info] except for call statements for which it gives the list of all the information in the signature of the call. *) - val find_all: ('a, 'b) t -> Key.t -> 'a list + val find_all : ('ni, 'ci) t -> Key.t-> 'ni list (** find the information stored for the call and its signature ) - val find_call: ('a, 'b) t -> Cil_types.stmt -> 'b option 'a Signature.t - val find_call_key: ('a, 'b) t -> Key.t -> 'b option * 'a Signature.t + val find_call : + ('ni, 'ci) t -> Cil_types.stmt -> 'ci option * 'ni Signature.t + val find_call_key : ('ni, 'ci) t -> Key.t -> 'ci option * 'ni Signature.t (** find the information stored for the call ) - val find_info_call: ('a, 'b) t -> Cil_types.stmt -> 'b - val find_info_call_key: ('a, 'b) t -> Key.t -> 'b + val find_info_call : ('ni, 'ci) t -> Cil_types.stmt -> 'ci + val find_info_call_key : ('ni, 'ci) t -> Key.t -> 'ci + + val fold_calls : + (Key.t_call_id-> 'ci option 'ni Signature.t -> 'c -> 'c) -> + ('ni, 'ci) t -> 'c -> 'c - val fold_calls: - (Cil_types.stmt -> 'b option * 'a Signature.t -> 'c -> 'c) -> - ('a, 'b) t -> 'c -> 'c + val fold : (Key.key -> 'ni -> 'a -> 'a) -> ('ni, 'ci) t -> 'a -> 'a (** store the information for the key. @raise AddError if there is already something stored. *) - val add: ('a, 'b) t -> Key.t -> 'a -> unit - + val add : ('ni, 'ci) t -> Key.t-> 'ni -> unit (** store the information for the key. Replace the previously stored information if any. *) - val add_or_replace: ('a, 'b) t -> Key.t -> 'a -> unit + val add_or_replace : ('ni, 'ci) t -> Key.t-> 'ni -> unit + val add_info_call : + ('ni, 'ci) t -> Key.t_call_id -> 'ci -> replace:bool -> unit + val add_info_call_key : ('ni, 'ci) t -> Key.t -> 'ci -> replace:bool -> unit + - val add_info_call: ('a, 'b) t -> Cil_types.stmt -> 'b -> replace:bool -> unit - val add_info_call_key: ('a, 'b) t -> Key.t -> 'b -> replace:bool -> unit + (** Structural destructor for unmarshaling ) + val t_descr: + ni:Structural_descr.t -> ci:Structural_descr.t -> Structural_descr.t end diff -Nru frama-c-20110201+carbon+dfsg/src/pdg_types/pdgMarks.ml frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgMarks.ml --- frama-c-20110201+carbon+dfsg/src/pdg_types/pdgMarks.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgMarks.ml 2011-10-10 08:38:28.000000000 +0000 @@ -83,12 +83,11 @@ type t_mark type t_call_info - type t_idx = (t_mark, t_call_info) PdgIndex.FctIndex.t - - type t = PdgTypes.Pdg.t t_idx + type t_fi = (t_mark, t_call_info) PdgIndex.FctIndex.t + type t = PdgTypes.Pdg.t * t_fi val create : PdgTypes.Pdg.t -> t - val get_idx : t -> t_idx + val get_idx : t -> t_fi type t_mark_info_inter = t_mark t_info_inter @@ -113,21 +112,20 @@ module F_Fct (M : T_Mark) : T_Fct with type t_mark = M.t and type t_call_info = M.t_call_info - and type t_idx = (M.t, M.t_call_info) FctIndex.t = struct type t_mark = M.t type t_call_info = M.t_call_info - type t_idx = (t_mark, t_call_info) FctIndex.t - type t = Pdg.t * t_idx + type t_fi = (t_mark, t_call_info) PdgIndex.FctIndex.t + type t = Pdg.t * t_fi type t_mark_info_inter = t_mark t_info_inter let empty_to_prop = ([], []) let create pdg = - let idx = (FctIndex.create 100) (* TODO Pdg.get_index_size pdg ) + let idx = (PdgIndex.FctIndex.create 17) ( TODO Pdg.get_index_size pdg ) in (pdg, idx) let get_idx (_pdg, idx) = idx @@ -146,11 +144,11 @@ begin ( simple node ) let new_mark, mark_to_prop = try - let old_mark = FctIndex.find_info fm node_key in + let old_mark = PdgIndex.FctIndex.find_info fm node_key in let new_m, m_prop = M.combine old_mark mark in (new_m, m_prop) - with PdgIndex.NotFound -> (mark, mark) - in FctIndex.add_or_replace fm node_key new_mark; + with Not_found -> (mark, mark) + in PdgIndex.FctIndex.add_or_replace fm node_key new_mark; mark_to_prop end with PdgIndex.CallStatement -> ( call statement ) assert false @@ -204,16 +202,16 @@ then (c, add_out_key l out_key)::tl else (c, l)::(add_out tl call out_key) in - match key with - | Key.SigCallKey (call, Signature.Out out_key) -> - let in_marks, out_marks = to_prop in - let call = Key.call_from_id call in - let new_out_marks = add_out out_marks call out_key in - (in_marks, new_out_marks) - | Key.SigKey (Signature.In in_key) -> - let to_prop = add_in_to_to_prop to_prop in_key mark in - to_prop - | _ -> ( nothing to do ) to_prop + match key with + | Key.SigCallKey (call, Signature.Out out_key) -> + let in_marks, out_marks = to_prop in + let call = Key.call_from_id call in + let new_out_marks = add_out out_marks call out_key in + (in_marks, new_out_marks) + | Key.SigKey (Signature.In in_key) -> + let to_prop = add_in_to_to_prop to_prop in_key mark in + to_prop + | _ -> ( nothing to do *) to_prop (** mark the nodes and their dependencies with the given mark. @@ -223,9 +221,11 @@ * ) let rec add_node_mark_rec pdg fm node_marks to_prop = let mark_node_and_dpds to_prop (node, z_opt, mark) = + Kernel.debug ~level:2 + "[pdgMark] add mark to node %a" PdgTypes.Node.pretty node; let node_key = PdgTypes.Node.elem_key node in let node_key = match z_opt with - | None -> node_key + | None -> node_key | Some z -> match node_key with | Key.SigCallKey (call, Signature.Out (Signature.OutLoc out_z)) -> @@ -240,7 +240,7 @@ to_prop end else begin Kernel.debug ~level:2 - "[pdgMark] mark_and_propagate = to propagate %a@\n" + "[pdgMark] mark_and_propagate = to propagate %a@\n" M.pretty mark_to_prop; let to_prop = add_to_to_prop to_prop node_key mark_to_prop in let dpds_info = PdgTypes.Pdg.get_all_direct_dpds pdg node in @@ -256,13 +256,13 @@ let process to_prop (sel, mark) = match sel with | SelNode (n, z_opt) -> Kernel.debug ~level:2 - "[pdgMark] mark_and_propagate start with %a@\n" + "[pdgMark] mark_and_propagate start with %a@\n" PdgTypes.Node.pretty_with_part (n, z_opt); add_node_mark_rec pdg idx [(n, z_opt, mark)] to_prop | SelIn loc -> let in_key = Key.implicit_in_key loc in Kernel.debug ~level:2 - "[pdgMark] mark_and_propagate start with %a@\n" + "[pdgMark] mark_and_propagate start with %a@\n" Key.pretty in_key; let mark_to_prop = add_mark pdg idx in_key mark in if M.is_bottom mark_to_prop then to_prop @@ -274,8 +274,11 @@ module type T_Proj = sig type t - type t_fct + type t_mark + type t_call_info + type t_fct = (t_mark, t_call_info) PdgIndex.FctIndex.t + val empty : t val find_marks : t -> Cil_types.varinfo -> t_fct option val mark_and_propagate : diff -Nru frama-c-20110201+carbon+dfsg/src/pdg_types/pdgMarks.mli frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgMarks.mli --- frama-c-20110201+carbon+dfsg/src/pdg_types/pdgMarks.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgMarks.mli 2011-10-10 08:38:28.000000000 +0000 @@ -107,12 +107,11 @@ type t_mark type t_call_info - type t_idx = (t_mark, t_call_info) PdgIndex.FctIndex.t - - type t = PdgTypes.Pdg.t t_idx + type t_fi = (t_mark, t_call_info) PdgIndex.FctIndex.t + type t = PdgTypes.Pdg.t * t_fi val create : PdgTypes.Pdg.t -> t - val get_idx : t -> t_idx + val get_idx : t -> t_fi type t_mark_info_inter = t_mark t_info_inter @@ -135,8 +134,10 @@ It is defined in PDG pluggin *) module type T_Proj = sig type t - type t_fct + type t_mark + type t_call_info + type t_fct = (t_mark, t_call_info) PdgIndex.FctIndex.t val empty: t val find_marks: t -> Cil_types.varinfo -> t_fct option diff -Nru frama-c-20110201+carbon+dfsg/src/pdg_types/pdgTypes.ml frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgTypes.ml --- frama-c-20110201+carbon+dfsg/src/pdg_types/pdgTypes.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgTypes.ml 2011-10-10 08:38:28.000000000 +0000 @@ -26,50 +26,95 @@ open Cil_types -(** this one shouldn't occur, but... *) -exception Pdg_Internal_Error of string -module Elem = struct +(** Node.t is the type of the PDG vertex. + [compare] and [pretty] are needed by [Abstract_interp.Make_Lattice_Set]. ) +module Node = struct type key = PdgIndex.Key.t type tt = { id : int; key : key } - let make counter key = - {id = (incr counter; - if !counter = -1 then - failwith "Internal limit reached in PDG counter"; - !counter); + module Counter = + State_builder.Counter(struct let name = "PdgTypes.Node.Counter" end) + + let make key = + {id = Counter.next (); key = key} let key e = e.key let print_id fmt e = Format.fprintf fmt "%d" e.id - include Datatype.Make - (struct - type t = tt - let name = "PdgTypes.Elem" - let structural_descr = - Structural_descr.t_record - [| Structural_descr.p_int; PdgIndex.Key.packed_descr |] - let reprs = [ { id = -1; key = PdgIndex.Key.top_input } ] - let compare e1 e2 = Datatype.Int.compare e1.id e2.id - let hash e = e.id - let equal e1 e2 = e1.id = e2.id - let pretty = print_id - let rehash = Datatype.identity - let copy = Datatype.undefined - let internal_pretty_code = Datatype.undefined - let varname = Datatype.undefined - let mem_project = Datatype.never_any_project - end) + let elem_id n = n.id + let elem_key n = key n + let stmt n = PdgIndex.Key.stmt n.key + + ( BY: not sure it is a good idea to use (=) on keys, which contain + Cil structures. Disabled for now + (** tells if the node represent the same thing that the given key. ) + let equivalent n key = (elem_key n) = key + ) + + let print_id fmt n = + Format.fprintf fmt "n:%a" print_id n + + include Datatype.Make_with_collections + (struct + type t = tt + let name = "PdgTypes.Elem" + let reprs = [ { id = -1; key = PdgIndex.Key.top_input } ] + let structural_descr = Structural_descr.t_record + [| Structural_descr.p_int; PdgIndex.Key.packed_descr |] + let compare e1 e2 = Datatype.Int.compare e1.id e2.id + let hash e = e.id + let equal e1 e2 = e1.id = e2.id + let pretty = print_id + let rehash = Datatype.identity + let copy = Datatype.undefined + let internal_pretty_code = Datatype.undefined + let varname = Datatype.undefined + let mem_project = Datatype.never_any_project + end) + + let pretty_list fmt l = + List.iter (fun n -> Format.fprintf fmt " %a" pretty n) l + + let pretty_with_part fmt (n, z_part) = + Format.fprintf fmt "%a" pretty n; + match z_part with None -> () + | Some z -> Format.fprintf fmt "(restrict to @[<h 1>%a@])" + Locations.Zone.pretty z + + let pretty_node fmt n = + Format.fprintf fmt "[Elem] %d : %a" (elem_id n) + PdgIndex.Key.pretty (elem_key n) + + let pretty_nodes fmt nodes = + let pretty_node n = Format.fprintf fmt "%a@." pretty_node n in + List.iter pretty_node nodes end +module NodeSet = Hptset.Make(struct include Node let id = elem_id end) + (struct let v = [ [ ] ] end) + (struct let l = [ Ast.self ] end) + +(** set of nodes of the graph *) +module NodeSetLattice = struct + include Abstract_interp.Make_Lattice_Set(Node) + type t_elt = O.elt + let tag = hash + let default _v _a _b : t = empty + let defaultall _v : t = empty +end + +module LocInfo = Lmap_bitwise.Make_bitwise (NodeSetLattice) + + (** Edges label for the Program Dependence Graph. *) module Dpd : sig - type t + include Datatype.S (** used to speak about the different kinds of dependencies *) type td = Ctrl | Addr | Data @@ -89,9 +134,6 @@ val is_dpd : td -> t -> bool val is_bottom : t -> bool - (** total order. Used only to sort...*) - val compare : t -> t -> int - val equal : t -> t -> bool val is_included : t -> t -> bool val combine : t -> t -> t @@ -102,91 +144,63 @@ (** remove the flags that are in m2 for m1 ) val minus : t -> t -> t + val pretty_td : Format.formatter -> td -> unit val pretty : Format.formatter -> t -> unit end = struct - type t = {addr : bool; data: bool; ctrl:bool } type td = Ctrl | Addr | Data + let pretty_td fmt td = + Format.fprintf fmt "%s" + (match td with Ctrl -> "c" | Addr -> "a" | Data -> "d") + + include Datatype.Int ( Encoding: %b addr; %b data; %b control ) + let maddr = 0x100 + let mdata = 0x010 + let mctrl = 0x001 - ( internal constructor ) - let create ?(a=false) ?(d=false) ?(c=false) _ = - { addr = a; data = d; ctrl = c } - - ( all possible value for [t] ) - let bottom = create () - let top = create ~a:true ~d:true ~c:true () - let a_dpd = create ~a:true () - let d_dpd = create ~d:true () - let c_dpd = create ~c:true () - let ad_dpd = create ~a:true ~d:true () - let ac_dpd = create ~a:true ~c:true () - let dc_dpd = create ~d:true ~c:true () - - ( external constructor sharing identical [t] values ) let make ?(a=false) ?(d=false) ?(c=false) _ = match a,d,c with - | false, false, false -> bottom - | true, false, false -> a_dpd - | false, true, false -> d_dpd - | false, false, true -> c_dpd - | true, true, false -> ad_dpd - | true, false, true -> ac_dpd - | false, true, true -> dc_dpd - | true, true, true -> top - - ( the use the external constructor ensures [==] can be used instead of [=] ) - let equal d1 d2 = d1 == d2 - - let make_simple kind = match kind with - | Ctrl -> c_dpd - | Addr -> a_dpd - | Data -> d_dpd + | false, false, false -> 0x000 + | true, false, false -> 0x100 + | false, true, false -> 0x010 + | false, false, true -> 0x001 + | true, true, false -> 0x110 + | true, false, true -> 0x101 + | false, true, true -> 0x011 + | true, true, true -> 0x111 + let bottom = 0x000 + let top = 0x111 let default = bottom - let is_addr d = d.addr - let is_ctrl d = d.ctrl - let is_data d = d.data + let is_addr d = (d land maddr) != 0 + let is_ctrl d = (d land mctrl) != 0 + let is_data d = (d land mdata) != 0 let is_dpd tdpd d = match tdpd with - | Addr -> d.addr - | Ctrl -> d.ctrl - | Data -> d.data + | Addr -> is_addr d + | Ctrl -> is_ctrl d + | Data -> is_data d - let is_bottom d = equal d bottom + let is_bottom = (=) bottom let adc_value d = (is_addr d, is_data d, is_ctrl d) - let compare : t -> t -> int = Extlib.compare_basic + let combine d1 d2 = d1 lor d2 + let inter d1 d2 = d1 land d2 + let intersect d1 d2 = inter d1 d2 != 0 + let is_included d1 d2 = combine d1 d2 = d2 - let combine d1 d2 = - if (d1 == d2) then d1 - else make - ~a:(d1.addr || d2.addr) - ~c:(d1.ctrl || d2.ctrl) - ~d:(d1.data || d2.data) () - - let inter d1 d2 = - if (d1 == d2) then d1 - else make - ~a:(d1.addr && d2.addr) - ~c:(d1.ctrl && d2.ctrl) - ~d:(d1.data && d2.data) () - - let is_included d1 d2 = let d = combine d1 d2 in equal d d2 - let intersect d1 d2 = let d = inter d1 d2 in not (is_bottom d) + let make_simple kind = match kind with + | Ctrl -> mctrl + | Addr -> maddr + | Data -> mdata let add d kind = combine d (make_simple kind) - let minus adc1 adc2 = - let a1, d1, c1 = adc_value adc1 in - let a2, d2, c2 = adc_value adc2 in - let a = if a2 then false else a1 in - let d = if d2 then false else d1 in - let c = if c2 then false else c1 in - make ~a ~d ~c () + let minus adc1 adc2 = adc1 land (lnot adc2) let pretty fmt d = Format.fprintf fmt "[%c%c%c]" (if is_addr d then 'a' else '-') @@ -196,23 +210,22 @@ end module DpdZone : sig - type t + include Datatype.S + val is_dpd : Dpd.td -> t -> bool val make : Dpd.td -> Locations.Zone.t option -> t val add : t -> Dpd.td -> Locations.Zone.t option -> t val kind_and_zone : t -> Dpd.t Locations.Zone.t option val dpd_zone : t -> Locations.Zone.t option - (** total order. Used only to sort...) - val compare : t -> t -> int - val equal : t -> t -> bool - val default : t val pretty : Format.formatter -> t -> unit + val tag: t -> int end = struct - type t = Dpd.t Locations.Zone.t option (* None == Locations.Zone.Top ) + include Datatype.Pair(Dpd)(Datatype.Option(Locations.Zone)) + ( None == Locations.Zone.Top ) let dpd_kind dpd = fst dpd let dpd_zone dpd = snd dpd @@ -223,39 +236,13 @@ let is_dpd k dpd = Dpd.is_dpd k (dpd_kind dpd) - let equal dpd1 dpd2 = - let cmp = Dpd.equal (dpd_kind dpd1) (dpd_kind dpd2) in - if cmp then - match (dpd_zone dpd1), (dpd_zone dpd2) with - | None, None -> true - | Some z1, Some z2 -> Locations.Zone.equal z1 z2 - | _, _ -> false - else false - - - let compare dpd1 dpd2 = - if equal dpd1 dpd2 then 0 - else assert false ( is this useful ? TODO ? ) - ( - let cmp = Dpd.compare (dpd_kind dpd1) (dpd_kind dpd2) in - if cmp = 0 then - match (dpd_zone dpd1), (dpd_zone dpd2) with - | None, None -> 0 - | _, None -> -1 - | None, _ -> 1 - | Some z1, Some z2 -> - if Locations.Zone.equal z1 z2 then 0 - else assert false (* is this useful ? TODO ? ) - else cmp - ) - let add ((d1,z1) as dpd) k z = let d = Dpd.add d1 k in let z = match z1, z with | None, _ -> z1 | _, None -> z | Some zz1, Some zz2 -> - (* we are loosing some precision here because for instance : + (* we are losing some precision here because for instance : * (zz1, addr) + (zz2, data) = (zz1 U zz2, data+addr) *) let zz = Locations.Zone.join zz1 zz2 in match zz with @@ -271,46 +258,134 @@ match (dpd_zone dpd) with None -> () | Some z -> Format.fprintf fmt "@[<h 1>(%a)@]" Locations.Zone.pretty z + + let tag = hash end -(** The graph itself. -* It uses ocamlgraph -* {{:http://ocamlgraph.lri.fr/doc/Imperative.S.concreteLabeled.html}Graph.Imperative.Digraph}. -* @see <http://ocamlgraph.lri.fr/> ocamlgraph web site -*) +(** The graph itself. ) module G = struct - module IGraph = Graph.Imperative.Digraph.AbstractLabeled(Elem)(DpdZone) - module E = IGraph.E - module V = IGraph.V - - ( Could be declared private out of G if the sig was explicit. ) - type t = { counter : int ref; graph : IGraph.t } - - let create = - fun () -> - let counter = ref (-1) in (BUG: Should be ok but slicing fails if - it is not shared among all graphs?????? ) - { counter = counter; - graph = IGraph.create ()} + ( Hashtbl to maps of nodes to dpdzone. Used to encode one-directional graphs + whoses nodes are Node.t, and labels on edges are DpdZone. ) + module V = struct include Node let id = elem_id end + module E = struct + type t = Node.t DpdZone.t * Node.t + type label = DpdZone.t + let src (n, _, _) = n + let dst (_, _, n) = n + let label (_, l, _) = l + end + + module To = Hptmap.Make(V)(DpdZone)(Hptmap.Comp_unused) + (struct let v = [[]] end)(struct let l = [Ast.self] end) + + module OneDir = Node.Hashtbl.Make(To) + + let add_node_one_dir g v = + if not (Node.Hashtbl.mem g v) then + Node.Hashtbl.add g v To.empty + + let add_edge_one_dir g vsrc vdst lbl = + let cur = try Node.Hashtbl.find g vsrc with Not_found -> To.empty in + let cur = To.add vdst lbl cur in + Node.Hashtbl.replace g vsrc cur + + let remove_edge_one_dir g vsrc vdst = + try + let cur = Node.Hashtbl.find g vsrc in + let cur = To.remove vdst cur in + Node.Hashtbl.replace g vsrc cur + with Not_found -> () + + let aux_iter_one_dir ?(rev=false) f v = + To.iter (fun v' lbl -> f (if rev then (v', lbl, v) else (v, lbl, v' : E.t))) + let iter_e_one_dir ?(rev=false) f g v = + let to_ = Node.Hashtbl.find g v in + aux_iter_one_dir ~rev f v to_ + + let fold_e_one_dir ?(rev=false) f g v = + let to_ = Node.Hashtbl.find g v in + To.fold (fun v' lbl acc -> + f (if rev then (v', lbl, v) else (v, lbl, v' : E.t)) acc) to_ + + let fold_one_dir f g v = + let to_ = Node.Hashtbl.find g v in + To.fold (fun v' _ acc -> f v' acc) to_ + + (* Bi-directional graphs *) + + type g = { + d_graph: OneDir.t; + co_graph: OneDir.t; + } + + include Datatype.Make + (struct + include Datatype.Undefined + type t = g + let name = "PdgTypes.G" + let reprs = [ let h = Node.Hashtbl.create 0 in + { d_graph = h; co_graph = h} ] + let mem_project = Datatype.never_any_project + let rehash = Datatype.identity + open Structural_descr + let structural_descr = + t_record [| OneDir.packed_descr; OneDir.packed_descr;|] + end) + + let add_node g v = + add_node_one_dir g.d_graph v; + add_node_one_dir g.co_graph v; + ;; + let add_vertex = add_node + + let add_edge g vsrc lbl vdst = + add_edge_one_dir g.d_graph vsrc vdst lbl; + add_edge_one_dir g.co_graph vdst vsrc lbl; + ;; + + let remove_edge g vsrc vdst = + remove_edge_one_dir g.d_graph vsrc vdst; + remove_edge_one_dir g.co_graph vdst vsrc; + ;; + + let find_edge g v1 v2 = + let dsts = Node.Hashtbl.find g.d_graph v1 in + To.find v2 dsts + ;; + + let iter_vertex f g = Node.Hashtbl.iter (fun v _ -> f v) g.d_graph + let iter_edges_e f g = + Node.Hashtbl.iter (fun v _to -> aux_iter_one_dir f v _to) g.d_graph + + let iter_succ_e f g = iter_e_one_dir f g.d_graph + let fold_succ f g = fold_one_dir f g.d_graph + let fold_pred f g = fold_one_dir f g.co_graph + let fold_succ_e f g = fold_e_one_dir f g.d_graph + let fold_pred_e f g = fold_e_one_dir ~rev:true f g.co_graph + let iter_pred_e f g = iter_e_one_dir ~rev:true f g.co_graph + + let succ g v = fold_succ (fun n l -> n :: l) g v [] + let pred g v = fold_pred (fun n l -> n :: l) g v [] + + let create () = + { d_graph = Node.Hashtbl.create 17; + co_graph = Node.Hashtbl.create 17; } let find_dpd g v1 v2 = - let edge = IGraph.find_edge g.graph v1 v2 in - (edge, IGraph.E.label edge) + let lbl = find_edge g v1 v2 in + ((v1, lbl, v2), lbl) let add_elem g key = - let elem = Elem.make g.counter key in - let new_vertex = V.create elem in - IGraph.add_vertex g.graph new_vertex; - new_vertex + let elem = Node.make key in + add_vertex g elem; + elem let simple_add_dpd g v1 dpd v2 = - IGraph.add_edge_e g.graph (IGraph.E.create v1 dpd v2) + add_edge g v1 dpd v2 - let replace_dpd g edge new_dpd = - let v1 = IGraph.E.src edge in - let v2 = IGraph.E.dst edge in - IGraph.remove_edge_e g.graph edge; + let replace_dpd g (v1, _, v2) new_dpd = + remove_edge g v1 v2; simple_add_dpd g v1 new_dpd v2 let add_dpd graph v1 dpd_kind opt_zone v2 = @@ -323,93 +398,11 @@ let new_dpd = DpdZone.make dpd_kind opt_zone in simple_add_dpd graph v1 new_dpd v2 - let iter_vertex x g = IGraph.iter_vertex x g.graph - let iter_edges_e x g = IGraph.iter_edges_e x g.graph - let iter_succ_e x g y = IGraph.iter_succ_e x g.graph y - let fold_succ_e x g y z = IGraph.fold_succ_e x g.graph y z - let fold_succ x g y z = IGraph.fold_succ x g.graph y z - let iter_pred_e x g y = IGraph.iter_pred_e x g.graph y - let fold_pred x g y z = IGraph.fold_pred x g.graph y z - let fold_pred_e x g y z = IGraph.fold_pred_e x g.graph y z - let pred g x = IGraph.pred g.graph x - let succ g x = IGraph.succ g.graph x - - let edge_dpd e = DpdZone.kind_and_zone (IGraph.E.label e) + let edge_dpd (_, lbl, _) = DpdZone.kind_and_zone lbl let pretty_edge_label = DpdZone.pretty end -(** Node.t is the type of the PDG vertex. - [compare] and [pretty] are needed by [Abstract_interp.Make_Lattice_Set]. *) -module Node = struct - - let elem n = G.V.label n - let elem_id n = (elem n).Elem.id - let elem_key n = Elem.key (elem n) - let stmt n = PdgIndex.Key.stmt (elem_key n) - - (** tells if the node represent the same thing that the given key. ) - let equivalent n key = (elem_key n) = key - - let print_id fmt n = Elem.print_id fmt (elem n) - - include Datatype.Make_with_collections - (struct - include G.V - let name = "PdgTypes.Node" - let structural_descr = - ( ocamlgraph abstract vertex descriptor; - see ocamlgraph/src/imperative.ml ) - Structural_descr.t_record - [| Structural_descr.p_int; - Elem.packed_descr; - Structural_descr.p_int |] - let reprs = List.map G.V.create Elem.reprs - let rehash = Datatype.identity - let copy = Datatype.undefined - let varname = Datatype.undefined - let mem_project = Datatype.never_any_project - let pretty = print_id - let internal_pretty_code = Datatype.undefined - end) - -( - let add_simple_node g key = - let elem = Elem.make g key in - let new_vertex = G.V.create elem in - new_vertex -*) - - let pretty_list fmt l = - List.iter (fun n -> Format.fprintf fmt " %a" pretty n) l - - let pretty_with_part fmt (n, z_part) = - Format.fprintf fmt "n%a" pretty n; - match z_part with None -> () - | Some z -> Format.fprintf fmt "(restrict to @[<h 1>%a@])" - Locations.Zone.pretty z - -end - -module NodeSet = struct - include Set.Make(Node) - let add_list ?(set=empty) l = - List.fold_left (fun acc n -> add n acc) set l -end - -(** set of nodes of the graph ) -module NodeSetLattice = struct - include Abstract_interp.Make_Lattice_Set(Node) - type t_elt = O.elt - let tag = hash - let default _v _a _b : t = empty - ( raise (NoNodeForZone (Locations.Zone.default v a b)) ) - let defaultall _v : t = empty - ( raise (NoNodeForZone (Locations.Zone.defaultall v)) ) -end - -module LocInfo = Lmap_bitwise.Make_bitwise (NodeSetLattice) - ( DataState is associated with a program point and provide the dependancies for the data, ie. it stores for each location the nodes of the pdg where its value @@ -426,133 +419,39 @@ type t = t_data_state let name = "PdgTypes.Data_state" let reprs = - List.fold_left - (fun acc l -> - List.fold_left - (fun acc z -> { loc_info = l; under_outputs = z } :: acc) - acc - Locations.Zone.reprs) - [] - LocInfo.reprs + List.fold_left + (fun acc l -> + List.fold_left + (fun acc z -> { loc_info = l; under_outputs = z } :: acc) + acc + Locations.Zone.reprs) + [] + LocInfo.reprs + let rehash = Datatype.identity let structural_descr = - Structural_descr.t_record - [| LocInfo.packed_descr; Locations.Zone.packed_descr |] + Structural_descr.t_record + [| LocInfo.packed_descr; Locations.Zone.packed_descr |] let mem_project = Datatype.never_any_project end) -( Dynamic dependencies ) -module DynDpds : sig - type t - type t_node = Node.t - type t_dpds_list = t_node list - type t_dpds_lists - - val empty : t - val add_x_dpds : t -> t_node -> - data:t_dpds_list -> addr:t_dpds_list -> ctrl:t_dpds_list -> - unit - val clear : t -> unit - - val find_dpds : t -> t_node -> t_dpds_lists - val find_co_dpds : t -> t_node -> t_dpds_lists - val get_x_dpds : t_dpds_lists -> Dpd.td option -> t_dpds_list - - val iter_dpds : (G.E.t -> unit) -> t -> unit - -end = struct - type t_node = Node.t - type t_dpds_list = t_node list - - (** [DAC] order ie. data + addr + ctrl ) - type t_dpds_lists = t_dpds_list t_dpds_list * t_dpds_list - (** the node and its dependencies and codependencies lists ) - type t = (t_node t_dpds_lists * t_dpds_lists) Inthash.t - - let empty = Inthash.create 100 - - let is_empty dd = (Inthash.length dd) = 0 - - let clear dd = Inthash.clear dd - - let find_lists dd node = - let _n, dpds, codpds = Inthash.find dd (Node.elem_id node) in dpds, codpds - - let find_dpds dd node = let (dpds, _) = find_lists dd node in dpds - - let find_co_dpds dd node = let (_, codpds) = find_lists dd node in codpds - - let iter_dpds f dd = - let rec iter n tdpd ldpds = match ldpds with [] -> () - | d :: ldpds -> f (G.E.create n tdpd d); iter n tdpd ldpds - in - let do_f _n_id (n, (ldata, laddr, lctrl), _codpds) = - iter n (DpdZone.make Dpd.Data None) ldata; - iter n (DpdZone.make Dpd.Addr None) laddr; - iter n (DpdZone.make Dpd.Ctrl None) lctrl - in Inthash.iter do_f dd - - let get_x_dpds (ldata, laddr, lctrl) td = - match td with - | None -> ldata @ laddr @ lctrl - | Some Dpd.Data -> ldata | Some Dpd.Addr -> laddr | Some Dpd.Ctrl -> lctrl - - (** keeps the list ordered from the smallest to the largest elem_id ) - ( TODO : add_node_to_list for several nodes at a time ) - let add_node_to_list node_list node = - let n_id = Node.elem_id node in - let rec add node_list = - match node_list with - | [] -> [node] - | n :: tail -> - if (Node.elem_id n) < n_id then n :: (add tail) - else if n_id < (Node.elem_id n) then node :: node_list - else ( already in *) node_list - in add node_list - - let add_node_to_lists td lists node = - let (ldata, laddr, lctrl) = lists in - let lists = match td with - | Dpd.Data -> add_node_to_list ldata node, laddr, lctrl - | Dpd.Addr -> ldata, add_node_to_list laddr node, lctrl - | Dpd.Ctrl -> ldata, laddr, add_node_to_list lctrl node - in lists - - (** add the nodes in [data] [addr] [ctrl] to the [node] dependancies. - * If [x] is a new dependency of [node], we also have to add [node] in [x] - * codependencies ) - let add_x_dpds dd node ~data ~addr ~ctrl = - let add_codpd t x = ( add [node] in [x] codpds *) - let x_dpds, x_codpds = - try find_lists dd x with Not_found -> ([], [], []), ([], [], []) in - let x_codpds = add_node_to_lists t x_codpds node in - Inthash.replace dd (Node.elem_id x) (x, x_dpds, x_codpds) - in - let add t old_node_dpds new_dpd = - add_codpd t new_dpd; - add_node_to_lists t old_node_dpds new_dpd - in - let node_dpds, node_codpds = - try find_lists dd node with Not_found -> ([], [], []), ([], [], []) in - let node_dpds = List.fold_left (add Dpd.Data) node_dpds data in - let node_dpds = List.fold_left (add Dpd.Addr) node_dpds addr in - let node_dpds = List.fold_left (add Dpd.Ctrl) node_dpds ctrl in - Inthash.replace dd (Node.elem_id node) (node, node_dpds, node_codpds) -end - (** PDG for a function *) module Pdg = struct exception Top exception Bottom - type t_index = (Node.t, unit) PdgIndex.FctIndex.t - (** The nodes which are associated the each element. - * There is only one node for simple statements, - * but there are several for a call for instance. *) + type t_fi = (Node.t, unit) PdgIndex.FctIndex.t + (** The nodes which are associated the each element. + There is only one node for simple statements, + but there are several for a call for instance. ) + let t_fi_descr = + PdgIndex.FctIndex.t_descr ~ni:(Descr.str Node.descr) ~ci:Structural_descr.t_unit + + type t_def = { graph : G.t ; states : t_data_state Inthash.t ; - index : t_index ; + index : t_fi ; } type t_body = PdgDef of t_def | PdgTop | PdgBottom @@ -560,27 +459,25 @@ module Body_datatype = Datatype.Make (struct - include Datatype.Undefined(Serializable_undefined) - type t = t_body - let reprs = [ PdgTop; PdgBottom ] -( - (* [JS 2010/09/27] this descr is incorrect since its internal zones are - not rehashconsed (do not use Structural_descr.Abstract in all - positions containing hashconsed values) ) - let structural_descr = - Structural_descr.Structure - (Structural_descr.Sum [| [| - Structural_descr.pack - (Structural_descr.t_record [| - Structural_descr.pack Structural_descr.Abstract ( TODO ); - (let module H = Cil_datatype.Int_hashtbl.Make(Data_state) in - H.packed_descr); - Structural_descr.pack Structural_descr.Abstract ( TODO ); - |]) - |] |]) - ) - let name = "t_body" - let mem_project = Datatype.never_any_project + include Datatype.Undefined(Serializable_undefined) + type t = t_body + let reprs = [ PdgTop; PdgBottom ] + let rehash = Datatype.identity + open Structural_descr + let structural_descr = + Structure + (Sum [| [| + pack + (t_record [| + G.packed_descr; + (let module H = Cil_datatype.Int_hashtbl.Make(Data_state) in + H.packed_descr); + pack t_fi_descr; + |]) + |] |]) + + let name = "t_body" + let mem_project = Datatype.never_any_project end) let () = Type.set_ml_name Body_datatype.ty None @@ -613,12 +510,7 @@ let do_it acc (_k, n) = f acc n in PdgIndex.Signature.fold do_it acc call_pdg - - (* let remove_node pdg node = - G.remove_elem (get_graph pdg) node; - PdgIndex.FctIndex.remove (get_index pdg) (Node.elem_key node) ) - - type dpd_info = (Node.t Locations.Zone.t option) + type dpd_info = (Node.t * Locations.Zone.t option) (** gives the list of nodes that depend to the given node with a given kind of dependency. @@ -665,19 +557,14 @@ in List.map get_info edges - let pretty_node fmt n = - let id = Node.elem_id n in - Format.fprintf fmt "[Elem] %d : " id; - let key = Node.elem_key n in - PdgIndex.Key.pretty fmt key - - let pretty_nodes fmt nodes = - let pretty_node n = Format.fprintf fmt "%a@." pretty_node n in - List.iter pretty_node nodes - let pretty_graph ?(bw=false) fmt graph = + let all = (* Sorted print is nicer for the user ) + let r = ref [] in + G.iter_vertex (fun n -> r := n :: !r) graph; + List.sort Node.compare !r + in let iter = if bw then G.iter_pred_e else G.iter_succ_e in - let print_node n = Format.fprintf fmt "%a@." pretty_node n in + let print_node n = Format.fprintf fmt "%a@." Node.pretty_node n in let print_dpd d = let dpd_kind = G.E.label d in if bw then Format.fprintf fmt " <-%a- %d@." G.pretty_edge_label dpd_kind @@ -689,7 +576,7 @@ print_node n; iter print_dpd graph n in - G.iter_vertex print_node_and_dpds graph + List.iter print_node_and_dpds all let pretty_bw ?(bw=false) fmt pdg = try @@ -715,14 +602,14 @@ let iter_vertex f pdg = try - let graph = get_graph pdg in + let graph = get_graph pdg in G.iter_vertex f graph with Top | Bottom -> () let iter_edges_e f pdg = try - let graph = get_graph pdg in - let f_static e = f (e, false) in + let graph = get_graph pdg in + let f_static e = f (e, false) in G.iter_edges_e f_static graph; with Top | Bottom -> () @@ -772,9 +659,6 @@ sh_box, txt | _ -> sh_box, "???" in sh, color_stmt, txt - ( | PdgIndex.Key.Annot _ -> - let txt = Pretty_utils.sfprintf "%a" PdgIndex.Key.pretty key in - (`Shape `Doublecircle), color_annot, txt ) | PdgIndex.Key.CallStmt call -> let call_stmt = PdgIndex.Key.call_from_id call in let txt = Pretty_utils.sfprintf "%a" @@ -783,8 +667,8 @@ in sh_box, color_call, txt | PdgIndex.Key.SigCallKey (_call, sgn) -> let txt = - Pretty_utils.sfprintf "%a" PdgIndex.Signature.pretty_key sgn - in + Pretty_utils.sfprintf "%a" PdgIndex.Signature.pretty_key sgn + in sh_box, color_elem_call, txt | PdgIndex.Key.Label _ -> let txt = Pretty_utils.sfprintf "%a" PdgIndex.Key.pretty key in @@ -797,28 +681,28 @@ let d, z = G.edge_dpd e in let attrib = [] in let attrib = match z with - | None -> attrib - | Some z -> + | None -> attrib + | Some z -> let txt = Pretty_utils.sfprintf "@[<h 1>%a@]" Locations.Zone.pretty z in (`Label txt) :: attrib in let attrib = - let color = + let color = if Dpd.is_data d then (if dynamic then 0xFF00FF else 0x0000FF) else (if dynamic then 0xFF0000 else 0x000000) - in (`Color color) :: attrib + in (`Color color) :: attrib in let attrib = - if Dpd.is_ctrl d then (`Arrowhead `Odot)::attrib else attrib + if Dpd.is_ctrl d then (`Arrowhead `Odot)::attrib else attrib in let attrib = - if Dpd.is_addr d then (`Style `Dotted)::attrib else attrib + if Dpd.is_addr d then (`Style `Dotted)::attrib else attrib in attrib let get_subgraph v = let mk_subgraph name attrib = - let attrib = (`Style `Filled) :: attrib in + let attrib = (`Style `Filled) :: attrib in Some { Graph.Graphviz.DotAttributes.sg_name= name; Graph.Graphviz.DotAttributes.sg_attributes = attrib } in diff -Nru frama-c-20110201+carbon+dfsg/src/pdg_types/pdgTypes.mli frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgTypes.mli --- frama-c-20110201+carbon+dfsg/src/pdg_types/pdgTypes.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/pdg_types/pdgTypes.mli 2011-10-10 08:38:28.000000000 +0000 @@ -26,8 +26,6 @@ function. @plugin development guide ) -exception Pdg_Internal_Error of string - (** [Dpd] stands for 'dependence'. This object is used as a label on the edges * of the PDG. There are three kinds of dependencies : * - control dependency, @@ -62,6 +60,7 @@ val inter : t -> t -> t val minus : t -> t -> t + val pretty_td : Format.formatter -> td -> unit val pretty : Format.formatter -> t -> unit end @@ -72,56 +71,54 @@ val elem_id : t -> int val elem_key : t -> PdgIndex.Key.t val stmt : t -> Cil_types.stmt option - val equivalent : t -> PdgIndex.Key.t -> bool + (val equivalent : t -> PdgIndex.Key.t -> bool) val pretty_list : Format.formatter -> t list -> unit val pretty_with_part : Format.formatter -> (t * Locations.Zone.t option) -> unit + val pretty_node: Format.formatter -> t -> unit end -module NodeSet : sig - include Set.S with type elt = Node.t - val add_list : ?set:t -> Node.t list -> t -end +module NodeSet : Hptset.S with type elt = Node.t (** Program dependence graph main part : the nodes of the graph represent * computations, and the edges represent the dependencies between these * computations. ) -module G : - sig +module G : sig +( include Datatype.S) + type t + module V : sig type t = Node.t end + module E : sig type t - module V : sig type t = Node.t end - module E : - sig - type t - type label - val src : t -> Node.t - val dst : t -> Node.t - val label : t -> label - end - - val create : unit -> t - - val add_elem : t -> PdgIndex.Key.t -> Node.t - val add_dpd : t -> Node.t -> - Dpd.td -> Locations.Zone.t option -> Node.t -> unit - ( val replace_dpd : t -> E.t -> Dpd.t -> unit ) - ( val find_dpd : t -> Node.t -> Node.t -> E.t * Dpd.t ) - - val succ : t -> Node.t -> Node.t list - val pred : t -> Node.t -> Node.t list - - val iter_vertex : (Node.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - val iter_succ_e : (E.t -> unit) -> t -> Node.t -> unit - val fold_succ_e : (E.t -> 'a -> 'a) -> t -> Node.t -> 'a -> 'a - val fold_succ : (Node.t -> 'a -> 'a) -> t -> Node.t -> 'a -> 'a - val iter_pred_e : (E.t -> unit) -> t -> Node.t -> unit - val fold_pred : (Node.t -> 'a -> 'a) -> t -> Node.t -> 'a -> 'a - - val edge_dpd : E.t -> Dpd.t Locations.Zone.t option - val pretty_edge_label : Format.formatter -> E.label -> unit + type label + val src : t -> Node.t + val dst : t -> Node.t + val label : t -> label end + val create : unit -> t + + val add_elem : t -> PdgIndex.Key.t -> Node.t + val add_dpd : + t -> Node.t -> Dpd.td -> Locations.Zone.t option -> Node.t -> unit + + (* val replace_dpd : t -> E.t -> Dpd.t -> unit ) + ( val find_dpd : t -> Node.t -> Node.t -> E.t * Dpd.t ) + + val succ : t -> Node.t -> Node.t list + val pred : t -> Node.t -> Node.t list + + val iter_vertex : (Node.t -> unit) -> t -> unit + val iter_edges_e : (E.t -> unit) -> t -> unit + val iter_succ_e : (E.t -> unit) -> t -> Node.t -> unit + val fold_succ_e : (E.t -> 'a -> 'a) -> t -> Node.t -> 'a -> 'a + val fold_succ : (Node.t -> 'a -> 'a) -> t -> Node.t -> 'a -> 'a + val iter_pred_e : (E.t -> unit) -> t -> Node.t -> unit + val fold_pred : (Node.t -> 'a -> 'a) -> t -> Node.t -> 'a -> 'a + + val edge_dpd : E.t -> Dpd.t Locations.Zone.t option + val pretty_edge_label : Format.formatter -> E.label -> unit +end + module NodeSetLattice : sig include Abstract_interp.Lattice_Set with type O.elt=Node.t val default : Base.t -> Abstract_interp.Int.t -> Abstract_interp.Int.t -> t @@ -163,6 +160,8 @@ val fold_call_nodes : ('a -> Node.t -> 'a) -> 'a -> t -> Cil_types.stmt -> 'a + (** a dependency to another node. The dependency can be restricted to a zone. + * (None means no restriction ie. total dependency) ) type dpd_info = (Node.t Locations.Zone.t option) val get_all_direct_dpds : t -> Node.t -> dpd_info list @@ -171,20 +170,36 @@ val get_all_direct_codpds : t -> Node.t -> dpd_info list val get_x_direct_codpds : Dpd.td -> t -> Node.t -> dpd_info list - (* val get_all_direct_edges : t -> Node.t -> - (Dpd.t * Locations.Zone.t option * Node.t) list U*) val pretty_bw : ?bw:bool -> Format.formatter -> t -> unit val pretty_graph : ?bw:bool -> Format.formatter -> G.t -> unit - val pretty_node: Format.formatter -> Node.t -> unit - type t_index = (Node.t, unit) PdgIndex.FctIndex.t - val get_index : t -> t_index + type t_fi = (Node.t, unit) PdgIndex.FctIndex.t + + val get_index : t -> t_fi (** [make fundec graph states index] ) val make : - Kernel_function.t -> G.t -> t_data_state Inthash.t -> t_index -> t + Kernel_function.t -> G.t -> t_data_state Inthash.t -> t_fi -> t val get_states : t -> t_data_state Inthash.t val build_dot: string -> t -> unit + module Printer : sig + val iter_vertex : (G.V.t -> unit) -> t -> unit + val iter_edges_e : (G.E.t bool -> unit) -> t -> unit + val graph_attributes : t -> Graph.Graphviz.DotAttributes.graph list + val default_vertex_attributes : t -> Graph.Graphviz.DotAttributes.vertex list + val vertex_name : G.V.t -> string + val vertex_attributes : G.V.t -> Graph.Graphviz.DotAttributes.vertex list + val get_subgraph : G.V.t -> Graph.Graphviz.DotAttributes.subgraph option + val default_edge_attributes : 'a -> Graph.Graphviz.DotAttributes.edge list + val edge_attributes : G.E.t * bool -> Graph.Graphviz.DotAttributes.edge list + end + end + +(* +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/postdominators/compute.ml frama-c-20111001+nitrogen+dfsg/src/postdominators/compute.ml --- frama-c-20110201+carbon+dfsg/src/postdominators/compute.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/postdominators/compute.ml 2011-10-10 08:38:09.000000000 +0000 @@ -22,11 +22,10 @@ open Cil_types open Cil -open Db_types open Db open Cil_datatype -module Parameters = +module DomKernel = Plugin.Register (struct let name = "dominators" @@ -36,20 +35,20 @@ module DomSet = struct - type domset = Value of Stmt.Set.t | Top + type domset = Value of Stmt.Hptset.t | Top let inter a b = match a,b with | Top,Top -> Top | Value v, Top | Top, Value v -> Value v - | Value v, Value v' -> Value (Stmt.Set.inter v v') + | Value v, Value v' -> Value (Stmt.Hptset.inter v v') let add v d = match d with | Top -> Top - | Value d -> Value (Stmt.Set.add v d) + | Value d -> Value (Stmt.Hptset.add v d) let mem v = function | Top -> true - | Value d -> Stmt.Set.mem v d + | Value d -> Stmt.Hptset.mem v d let map f = function | Top -> Top @@ -57,25 +56,26 @@ include Datatype.Make (struct - include Datatype.Serializable_undefined - type t = domset - let name = "postdominator" - let reprs = Top :: List.map (fun s -> Value s) Stmt.Set.reprs - let structural_descr = - Structural_descr.Structure - (Structural_descr.Sum [| [| Stmt.Set.packed_descr |] |]) - let pretty fmt = function - | Top -> Format.fprintf fmt "Top" - | Value d -> - Pretty_utils.pp_list ~pre:"@[{" ~sep:",@," ~suf:"}@]" - (fun fmt s -> Format.fprintf fmt "%d" s.sid) - fmt (Stmt.Set.elements d) - let equal a b = match a,b with - | Top,Top -> true - | Value _v, Top | Top, Value _v -> false - | Value v, Value v' -> Stmt.Set.equal v v' - let copy = map Cil_datatype.Stmt.Set.copy - let mem_project = Datatype.never_any_project + include Datatype.Serializable_undefined + type t = domset + let name = "dominator_set" + let reprs = Top :: List.map (fun s -> Value s) Stmt.Hptset.reprs + let structural_descr = + Structural_descr.Structure + (Structural_descr.Sum [| [| Stmt.Hptset.packed_descr |] |]) + let pretty fmt = function + | Top -> Format.fprintf fmt "Top" + | Value d -> + Pretty_utils.pp_iter ~pre:"@[{" ~sep:",@," ~suf:"}@]" + Stmt.Hptset.iter + (fun fmt s -> Format.fprintf fmt "%d" s.sid) + fmt d + let equal a b = match a,b with + | Top,Top -> true + | Value _v, Top | Top, Value _v -> false + | Value v, Value v' -> Stmt.Hptset.equal v v' + let copy = map Cil_datatype.Stmt.Hptset.copy + let mem_project = Datatype.never_any_project end) end @@ -124,21 +124,23 @@ let start = Kernel_function.find_first_stmt kf in try let _ = Dom.find start.sid in - Parameters.feedback "computed for function %a" - Kernel_function.pretty_name kf; + DomKernel.feedback ~level:2 "computed for function %a" + Kernel_function.pretty kf; with Not_found -> - Parameters.feedback "computing for function %a" - Kernel_function.pretty_name kf; + DomKernel.feedback ~level:2 "computing for function %a" + Kernel_function.pretty kf; let f = kf.fundec in let stmts = match f with | Definition (f,_) -> f.sallstmts - | Declaration _ -> Parameters.fatal "cannot compute for a leaf function" + | Declaration _ -> + DomKernel.fatal "cannot compute for a leaf function %a" + Kernel_function.pretty kf in List.iter (fun s -> Dom.add s.sid DomSet.Top) stmts; - Dom.replace start.sid (DomSet.Value (Stmt.Set.singleton start)); + Dom.replace start.sid (DomSet.Value (Stmt.Hptset.singleton start)); DomCompute.compute [start]; - Parameters.feedback "done for function %a" - Kernel_function.pretty_name kf + DomKernel.feedback ~level:2 "done for function %a" + Kernel_function.pretty kf let get_stmt_dominators f stmt = let do_it () = Dom.find stmt.sid in @@ -156,115 +158,206 @@ let display_dom () = Dom.iter - (fun k v -> Parameters.result "Stmt:%d@\n%a@\n======" k DomSet.pretty v) + (fun k v -> DomKernel.result "Stmt:%d@\n%a@\n======" k DomSet.pretty v) (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) -module PostDom = - Cil_state_builder.Inthash - (DomSet) - (struct - let name = "postdominator" - let dependencies = [ Ast.self ] - let size = 503 - let kind = `Internal - end) +module type MakePostDomArg = sig + val is_accessible: stmt -> bool + ( Evaluation of an expression which is supposed to be the condition of an + 'if'. The first boolean (resp. second) represents the possibility that + the expression can be non-zero (resp. zero), ie. true (resp. false). ) + val eval_cond: stmt -> exp -> bool bool -module PostComputer = struct + val dependencies: State.t list + val name: string +end - let name = "postdominator" - let debug = ref false +module MakePostDom(X: MakePostDomArg) = +struct - type t = DomSet.t - module StmtStartData = PostDom + module PostDom = + Cil_state_builder.Stmt_hashtbl + (DomSet) + (struct + let name = "postdominator." ^ X.name + let dependencies = Ast.self :: X.dependencies + let size = 503 + let kind = `Internal + end) - let pretty = DomSet.pretty + module PostComputer = struct - let combineStmtStartData _stmt ~old new_ = - let result = (* inter old ) new_ in - if DomSet.equal result old then None else Some result + let name = "postdominator" + let debug = ref false - let combineSuccessors = DomSet.inter + type t = DomSet.t + module StmtStartData = PostDom - let doStmt stmt = - !Db.progress (); - Parameters.debug "doStmt : %d" stmt.sid; - match stmt.skind with - | Return _ -> Dataflow.Done (DomSet.Value (Stmt.Set.singleton stmt)) - | _ -> Dataflow.Post (fun data -> DomSet.add stmt data) + let pretty = DomSet.pretty - let doInstr _ _ _ = Dataflow.Default + let combineStmtStartData _stmt ~old new_ = + ( No need to compute the intersection: the results can only decrease + (except on Top, but Top \inter Set = Set ) + let result = ( DomSet.inter old ) new_ in + if DomSet.equal result old then None else Some result - let filterStmt _stmt _next = true + let combineSuccessors = DomSet.inter - let funcExitData = DomSet.Value Stmt.Set.empty + let doStmt stmt = + !Db.progress (); + Postdominators_parameters.debug ~level:2 "doStmt: %d" stmt.sid; + match stmt.skind with + | Return _ -> Dataflow.Done (DomSet.Value (Stmt.Hptset.singleton stmt)) + | _ -> Dataflow.Post (fun data -> DomSet.add stmt data) -end -module PostCompute = Dataflow.BackwardsDataFlow(PostComputer) -let compute_postdom kf = - let return = Kernel_function.find_return kf in - try - let _ = PostDom.find return.sid in - Parameters.result "(post) computed for function %a" - Kernel_function.pretty_name kf - with Not_found -> - Parameters.feedback "computing (post) for function %a" - Kernel_function.pretty_name kf; - let f = kf.fundec in - let stmts = match f with - | Definition (f,_) -> f.sallstmts - | Declaration _ -> - Parameters.fatal "cannot compute postdominators for a leaf function" + let doInstr _ _ _ = Dataflow.Default + + ( We make special tests for 'if' statements without a 'then' or + 'else' branch. It can lead to better precision if we can evaluate + the condition of the 'if' with always the same truth value ) + let filterIf ifstmt next = match ifstmt.skind with + | If (e, { bstmts = sthen :: _ }, { bstmts = [] }, _) + when not (Stmt.equal sthen next) -> + ( [next] is the syntactic successor of the 'if', ie the + 'else' branch. If the condition is never false, then + [sthen] postdominates [next]. We must not follow the edge + from [ifstmt] to [next] ) + snd (X.eval_cond ifstmt e) + + | If (e, { bstmts = [] }, { bstmts = selse :: _ }, _) + when not (Stmt.equal selse next) -> + ( dual case *) + fst (X.eval_cond ifstmt e) + + | _ -> true + + let filterStmt pred next = + X.is_accessible pred && filterIf pred next + + + let funcExitData = DomSet.Value Stmt.Hptset.empty + + end + module PostCompute = Dataflow.Backwards(PostComputer) + + let compute_postdom kf = + let return = + try Kernel_function.find_return kf + with Kernel_function.No_Statement -> + Postdominators_parameters.abort + "No return statement for a function with body %a" + Kernel_function.pretty kf in - List.iter (fun s -> PostDom.add s.sid DomSet.Top) stmts; - PostCompute.compute [return]; - Parameters.feedback "done for function %a" - Kernel_function.pretty_name kf + try + let _ = PostDom.find return in + Postdominators_parameters.feedback ~level:2 "computed for function %a" + Kernel_function.pretty kf + with Not_found -> + Postdominators_parameters.feedback ~level:2 "computing for function %a" + Kernel_function.pretty kf; + let f = kf.fundec in + let stmts = match f with + | Definition (f,_) -> f.sallstmts + | Declaration _ -> + Postdominators_parameters.fatal + "cannot compute postdominators for leaf function %a" + Kernel_function.pretty kf + in + List.iter (fun s -> PostDom.add s DomSet.Top) stmts; + PostCompute.compute [return]; + Postdominators_parameters.feedback ~level:2 "done for function %a" + Kernel_function.pretty kf + + let get_stmt_postdominators f stmt = + let do_it () = PostDom.find stmt in + try do_it () + with Not_found -> compute_postdom f; do_it () + + (** @raise Db.PostdominatorsTypes.Top when the statement postdominators + * have not been computed ie neither the return statement is reachable, + * nor the statement is in a natural loop. *) + let stmt_postdominators f stmt = + match get_stmt_postdominators f stmt with + | DomSet.Value s -> + Postdominators_parameters.debug ~level:1 "Postdom for %d are %a" + stmt.sid Stmt.Hptset.pretty s; + s + | DomSet.Top -> raise Db.PostdominatorsTypes.Top + + let is_postdominator f ~opening ~closing = + let open_postdominators = get_stmt_postdominators f opening in + DomSet.mem closing open_postdominators + + let display_postdom () = + let disp_all fmt = + PostDom.iter + (fun k v -> Format.fprintf fmt "Stmt:%d -> @[%a@]\n" + k.sid PostComputer.pretty v) + in Postdominators_parameters.result "%t" disp_all + + let print_dot_postdom basename kf = + let filename = basename ^ "." ^ Kernel_function.get_name kf ^ ".dot" in + Print.build_dot filename kf; + Postdominators_parameters.result "dot file generated in %s" filename -let get_stmt_postdominators f stmt = - let do_it () = PostDom.find stmt.sid in - try do_it () - with Not_found -> compute_postdom f; do_it () +end + +module PostDomDb(X: MakePostDomArg)(DbPostDom: Db.PostdominatorsTypes.Sig) = +struct + include MakePostDom(X) + + let () = DbPostDom.compute := compute_postdom + let () = DbPostDom.is_postdominator := is_postdominator + let () = DbPostDom.stmt_postdominators := stmt_postdominators + let () = DbPostDom.display := display_postdom + let () = DbPostDom.print_dot := print_dot_postdom + +end + +module PostDomBasic = + PostDomDb( + struct + let is_accessible _ = true + let dependencies = [] + let name = "basic" + let eval_cond _ _ = true, true + end) + (Db.Postdominators) -(** @raise Db.Top_postdominators when the statement postdominators -* have not been computed ie neither the return statement is reachable, -* nor the statement is in a natural loop. ) -let stmt_postdominators f stmt = - match get_stmt_postdominators f stmt with - | DomSet.Value s -> s - | DomSet.Top -> raise Db.Postdominators.Top -let is_postdominator f ~opening ~closing = - let open_postdominators = get_stmt_postdominators f opening in - DomSet.mem closing open_postdominators - -let display_postdom () = - let disp_all fmt = - PostDom.iter - (fun k v -> Format.fprintf fmt "Stmt:%d\n%a\n======" k PostComputer.pretty v) - in Parameters.result "%t" disp_all - -let print_dot_postdom basename kf = - let filename = basename ^ "." ^ Kernel_function.get_name kf ^ ".dot" in - Print.build_dot filename kf; - Parameters.result "(post) dot file generated in %s" filename +let output () = + let dot_postdom = Postdominators_parameters.DotPostdomBasename.get () in + if dot_postdom <> "" then ( + Ast.compute (); + Globals.Functions.iter (!Db.Postdominators.print_dot dot_postdom) + ) + +let output, _ = State_builder.apply_once "Postdominators.Compute.output" + [PostDomBasic.PostDom.self] output + +let () = Db.Main.extend output + + +module PostDomVal = + PostDomDb( + struct + let is_accessible = Db.Value.is_reachable_stmt + let dependencies = [ Db.Value.self ] + let name = "value" + let eval_cond stmt _e = + Db.Value.condition_truth_value stmt -let main _fmt = () + end) + (Db.PostdominatorsValue) -let () = Db.Main.extend main let () = Db.Dominators.compute := compute_dom let () = Db.Dominators.is_dominator := is_dominator let () = Db.Dominators.stmt_dominators := stmt_dominators let () = Db.Dominators.display := display_dom -let () = Db.Postdominators.compute := compute_postdom -let () = Db.Postdominators.is_postdominator := is_postdominator -let () = Db.Postdominators.stmt_postdominators := stmt_postdominators -let () = Db.Postdominators.display := display_postdom -let () = Db.Postdominators.print_dot := print_dot_postdom - ( Local Variables: compile-command: "make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/postdominators/postdominators_parameters.ml frama-c-20111001+nitrogen+dfsg/src/postdominators/postdominators_parameters.ml --- frama-c-20110201+carbon+dfsg/src/postdominators/postdominators_parameters.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/postdominators/postdominators_parameters.ml 2011-10-10 08:38:09.000000000 +0000 @@ -27,6 +27,14 @@ let help = "computing postdominators of statements" end) +module DotPostdomBasename = + EmptyString + (struct + let option_name = "-dot-postdom" + let arg_name = "f" + let help = "put the postdominators of function <f> in basename.f.dot" + end) + (* Local Variables: compile-command: "LC_ALL=C make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/postdominators/postdominators_parameters.mli frama-c-20111001+nitrogen+dfsg/src/postdominators/postdominators_parameters.mli --- frama-c-20110201+carbon+dfsg/src/postdominators/postdominators_parameters.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/postdominators/postdominators_parameters.mli 2011-10-10 08:38:09.000000000 +0000 @@ -22,6 +22,9 @@ include Plugin.General_services +module DotPostdomBasename: Plugin.String + + (* Local Variables: compile-command: "LC_ALL=C make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/postdominators/print.ml frama-c-20111001+nitrogen+dfsg/src/postdominators/print.ml --- frama-c-20110201+carbon+dfsg/src/postdominators/print.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/postdominators/print.ml 2011-10-10 08:38:09.000000000 +0000 @@ -28,7 +28,7 @@ module Printer = struct - type t = string * (Stmt.Set.t option Kinstr.Hashtbl.t) + type t = string * (Stmt.Hptset.t option Kinstr.Hashtbl.t) module V = struct type t = Cil_types.stmt * bool let pretty fmt v = pretty_stmt fmt v @@ -54,7 +54,7 @@ match postdom with None -> () | Some postdom -> let do_edge p = f ((s, true), (p, true)) in - Stmt.Set.iter do_edge postdom + Stmt.Hptset.iter do_edge postdom in Kinstr.Hashtbl.iter do_s graph @@ -85,18 +85,18 @@ let get_postdom kf graph s = try match Kinstr.Hashtbl.find graph (Kstmt s) with - | None -> Stmt.Set.empty + | None -> Stmt.Hptset.empty | Some l -> l with Not_found -> try let postdom = !Db.Postdominators.stmt_postdominators kf s in - let postdom = Stmt.Set.remove s postdom in + let postdom = Stmt.Hptset.remove s postdom in Postdominators_parameters.debug "postdom for %d:%a = %a\n" - s.sid pretty_stmt s Stmt.Set.pretty postdom; + s.sid pretty_stmt s Stmt.Hptset.pretty postdom; Kinstr.Hashtbl.add graph (Kstmt s) (Some postdom); postdom - with Db.Postdominators.Top -> + with Db.PostdominatorsTypes.Top -> Kinstr.Hashtbl.add graph (Kstmt s) None; - raise Db.Postdominators.Top + raise Db.PostdominatorsTypes.Top (** [s_postdom] are [s] postdominators, including [s]. * We don't have to represent the relation between s and s. @@ -105,33 +105,34 @@ ) let reduce kf graph s = let remove p s_postdom = - if Stmt.Set.mem p s_postdom + if Stmt.Hptset.mem p s_postdom then try let p_postdom = get_postdom kf graph p in - let s_postdom = Stmt.Set.diff s_postdom p_postdom + let s_postdom = Stmt.Hptset.diff s_postdom p_postdom in s_postdom - with Db.Postdominators.Top -> assert false + with Db.PostdominatorsTypes.Top -> assert false ( p postdom s -> cannot be top ) else s_postdom ( p has already been removed from s_postdom ) in try let postdom = get_postdom kf graph s in - let postdom = Stmt.Set.fold remove postdom postdom in + let postdom = Stmt.Hptset.fold remove postdom postdom in Postdominators_parameters.debug "new postdom for %d:%a = %a\n" - s.sid pretty_stmt s Stmt.Set.pretty postdom; + s.sid pretty_stmt s Stmt.Hptset.pretty postdom; Kinstr.Hashtbl.replace graph (Kstmt s) (Some postdom) - with Db.Postdominators.Top -> + with Db.PostdominatorsTypes.Top -> () let rec build_reduced_graph kf graph stmts = List.iter (reduce kf graph) stmts let build_dot filename kf = - let stmts = match kf.Db_types.fundec with - | Db_types.Definition (fct, _) -> fct.sallstmts - | Db_types.Declaration _ -> - Kernel.abort "cannot compute for a function without body" + let stmts = match kf.fundec with + | Definition (fct, _) -> fct.sallstmts + | Declaration _ -> + Kernel.abort "cannot compute for a function without body %a" + Kernel_function.pretty kf in let graph = Kinstr.Hashtbl.create (List.length stmts) in let _ = build_reduced_graph kf graph stmts in diff -Nru frama-c-20110201+carbon+dfsg/src/project/dashtbl.ml frama-c-20111001+nitrogen+dfsg/src/project/dashtbl.ml --- frama-c-20110201+carbon+dfsg/src/project/dashtbl.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/dashtbl.ml 2011-10-10 08:38:25.000000000 +0000 @@ -121,22 +121,22 @@ type t = (D.t State.t) list State_tbl.t - let create = State_tbl.create + let create x = State_tbl.create x let clear = State_tbl.clear let add tbl s v = try - let l = State_tbl.find tbl s in - State_tbl.replace tbl s (v :: l) + let l = State_tbl.find tbl s in + State_tbl.replace tbl s (v :: l) with Not_found -> - State_tbl.add tbl s [ v ] + State_tbl.add tbl s [ v ] let replace ~on_clear tbl s v = begin try - let old = State_tbl.find tbl s in - List.iter (fun (_, s') -> on_clear s') old + let old = State_tbl.find tbl s in + List.iter (fun (_, s') -> on_clear s') old with Not_found -> - () + () end; State_tbl.replace tbl s [ v ] @@ -144,15 +144,15 @@ let remove_single tbl key s = try - match State_tbl.find tbl key with - | [] -> - assert false - | _ :: _ as l -> - match List.filter (fun (_, s') -> not (State.equal s s')) l with - | [] -> State_tbl.remove tbl key; - | _ :: _ as l -> State_tbl.replace tbl key l + match State_tbl.find tbl key with + | [] -> + assert false + | _ :: _ as l -> + match List.filter (fun (_, s') -> not (State.equal s s')) l with + | [] -> State_tbl.remove tbl key; + | _ :: _ as l -> State_tbl.replace tbl key l with Not_found -> - () + () let find tbl s = match State_tbl.find tbl s with @@ -165,23 +165,23 @@ let fold f tbl acc = State_tbl.fold - (fun s l acc -> List.fold_left (fun acc v -> f s v acc) acc l) - tbl - acc + (fun s l acc -> List.fold_left (fun acc v -> f s v acc) acc l) + tbl + acc let is_empty tbl = try - State_tbl.iter (fun _ _ -> raise Exit) tbl; - true; + State_tbl.iter (fun _ _ -> raise Exit) tbl; + true; with Exit -> - false + false let is_singleton tbl = try - State_tbl.fold - (fun _ _ second -> if second then raise Exit else true) tbl false; + State_tbl.fold + (fun _ _ second -> if second then raise Exit else true) tbl false; with Exit -> - false + false end @@ -189,16 +189,16 @@ type data = D.t type tbl = { h: Internal_tbl.t K.Hashtbl.t; - inverse: (key * State.t) list State_tbl.t } + inverse: (key * State.t) list State_tbl.t } include Datatype.Make - (struct - include Datatype.Undefined - type t = tbl - let name = Info.name - let reprs = - [ { h = K.Hashtbl.create 0; inverse = State_tbl.create 0 } ] - end) + (struct + include Datatype.Undefined + type t = tbl + let name = Info.name + let reprs = + [ { h = K.Hashtbl.create 0; inverse = State_tbl.create 0 } ] + end) (* Global invariant: only one binding by key. So never required to call [K.Hashtbl.find_all] ) @@ -223,9 +223,9 @@ let () = Project.register_todo_before_clear (fun _ -> todo_list := []) let () = Project.register_todo_after_clear - (fun p -> - let del () = List.iter (fun f -> f ()) !todo_list in - Project.on p del ()) + (fun p -> + let del () = List.iter (fun f -> f ()) !todo_list in + Project.on p del ()) let add f = todo_list := f :: !todo_list @@ -239,12 +239,12 @@ let keys = State_tbl.find inverse s in State_tbl.remove inverse s; let clear key s' = - try - let internal = K.Hashtbl.find h key in - Internal_tbl.remove_single internal s' s; - if Internal_tbl.is_empty internal then K.Hashtbl.remove h key - with Not_found -> - assert false + try + let internal = K.Hashtbl.find h key in + Internal_tbl.remove_single internal s' s; + if Internal_tbl.is_empty internal then K.Hashtbl.remove h key + with Not_found -> + assert false in List.iter (fun (key, s') -> clear key s') keys with Not_found -> @@ -263,11 +263,11 @@ let h = t.h in let tbl = K.Hashtbl.find h key in (try - let bindings = Internal_tbl.find_all tbl s in - let del = single_remove ~reset t in - List.iter (fun (_, c) -> del c) bindings + let bindings = Internal_tbl.find_all tbl s in + let del = single_remove ~reset t in + List.iter (fun (_, c) -> del c) bindings with Not_found -> - ()); + ()); if Internal_tbl.is_singleton tbl then K.Hashtbl.remove h key else Internal_tbl.remove tbl s with Not_found -> @@ -286,7 +286,7 @@ let clear ~reset t = if reset then Project.clear - ~selection:(State_selection.Dynamic.with_dependencies !G.self) (); + ~selection:(State_selection.Dynamic.with_dependencies !G.self) (); K.Hashtbl.clear t.h; State_tbl.clear t.inverse @@ -306,7 +306,7 @@ (State.get_unique_name local) (State.get_name !G.self) (fun fmt -> - List.iter (fun s -> Format.fprintf fmt "%S, " (State.get_name s)) deps);) + List.iter (fun s -> Format.fprintf fmt "%S, " (State.get_name s)) deps);) let value = v, local in let full_deps = match deps with [] -> [ State.dummy ] | _ :: _ -> deps in let inverse_binders = @@ -336,9 +336,9 @@ try let l = Internal_tbl.find_all (K.Hashtbl.find t.h key) s in List.iter - (fun (_, local) -> - State_dependency_graph.Dynamic.add_codependencies ~onto:local who) - l; + (fun (_, local) -> + State_dependency_graph.Dynamic.add_codependencies ~onto:local who) + l; l with Not_found -> [] @@ -359,44 +359,44 @@ ( do not get the same value twice ) let module S = Set.Make - (struct - type t = D.t State.t - let equal = (==) - (* cannot compare the first component but the second one is a - valid key ) - let compare (_, x) (_, y) = State.compare x y - end) + (struct + type t = D.t State.t + let equal = (==) + (* cannot compare the first component but the second one is a + valid key ) + let compare (_, x) (_, y) = State.compare x y + end) in fun ?(who=[]) t key -> let values = tbl_fold (fun _ -> S.add) t key S.empty in S.fold - (fun (_, local as res) acc -> - State_dependency_graph.Dynamic.add_codependencies ~onto:local who; - res :: acc) - values - [] + (fun (_, local as res) acc -> + State_dependency_graph.Dynamic.add_codependencies ~onto:local who; + res :: acc) + values + [] ( optimized ) let find_all_data = ( do not get the same value twice ) let module S = Set.Make - (struct - type t = D.t State.t - let equal = (==) - (* cannot compare the first component but the second one is a - valid key ) - let compare (_, x) (_, y) = State.compare x y - end) + (struct + type t = D.t State.t + let equal = (==) + (* cannot compare the first component but the second one is a + valid key ) + let compare (_, x) (_, y) = State.compare x y + end) in fun ?(who=[]) t key -> let values = tbl_fold (fun _ -> S.add) t key S.empty in S.fold - (fun (v, local) acc -> - State_dependency_graph.Dynamic.add_codependencies ~onto:local who; - v :: acc) - values - [] + (fun (v, local) acc -> + State_dependency_graph.Dynamic.add_codependencies ~onto:local who; + v :: acc) + values + [] ( optimized ) let find_all_states = @@ -405,11 +405,11 @@ fun ?(who=[]) t key -> let selfs = tbl_fold (fun _ (_, s) -> S.add s) t key S.empty in S.fold - (fun local acc -> - State_dependency_graph.Dynamic.add_codependencies ~onto:local who; - local :: acc) - selfs - [] + (fun local acc -> + State_dependency_graph.Dynamic.add_codependencies ~onto:local who; + local :: acc) + selfs + [] let mem t key = K.Hashtbl.mem t.h key let is_local t s = State_tbl.mem t.inverse s @@ -425,27 +425,27 @@ let iter f t = K.Hashtbl.iter (fun k -> - Internal_tbl.iter - (fun s v -> - let s = if State.is_dummy s then None else Some s in - f k s v)) + Internal_tbl.iter + (fun s v -> + let s = if State.is_dummy s then None else Some s in + f k s v)) t.h let fold f t acc = K.Hashtbl.fold (fun k -> - Internal_tbl.fold - (fun s v -> - let s = if State.is_dummy s then None else Some s in - f k s v)) + Internal_tbl.fold + (fun s v -> + let s = if State.is_dummy s then None else Some s in + f k s v)) t.h acc let memo ~reset f t name key deps = let olds = List.fold_left - (fun acc s -> try find_data t key s :: acc with Not_found -> acc) - [] - deps + (fun acc s -> try find_data t key s :: acc with Not_found -> acc) + [] + deps in let data = f olds in replace ~reset t name key deps data; @@ -455,50 +455,50 @@ let module S = Set.Make(State) in fun ~reset f t key -> try - let h = t.h in - let tbl = K.Hashtbl.find h key in - let keep, to_be_delete = - Internal_tbl.fold - (fun s (v, state as x) (keep, delete) -> - let s = if State.is_dummy s then None else Some s in - if f key s v then (s, x) :: keep, delete - else begin -( Format.printf "FILTERING %S (key is %S)@." - (State.get_name state) - (State.get_name s);) - keep, S.add state delete - end) - tbl - ([], S.empty) - in - S.iter (single_remove ~reset t) to_be_delete; - match keep with - | [] -> K.Hashtbl.remove h key - | _ :: _ -> - Internal_tbl.clear tbl; - List.iter - (fun (s, v) -> - let s = match s with None -> State.dummy | Some s -> s in - Internal_tbl.add tbl s v) - keep; + let h = t.h in + let tbl = K.Hashtbl.find h key in + let keep, to_be_delete = + Internal_tbl.fold + (fun s (v, state as x) (keep, delete) -> + let s = if State.is_dummy s then None else Some s in + if f key s v then (s, x) :: keep, delete + else begin +( Format.printf "FILTERING %S (key is %S)@." + (State.get_name state) + (State.get_name s);) + keep, S.add state delete + end) + tbl + ([], S.empty) + in + S.iter (single_remove ~reset t) to_be_delete; + match keep with + | [] -> K.Hashtbl.remove h key + | _ :: _ -> + Internal_tbl.clear tbl; + List.iter + (fun (s, v) -> + let s = match s with None -> State.dummy | Some s -> s in + Internal_tbl.add tbl s v) + keep; with Not_found -> - () + () module H = Hashtbl.Make (struct - type t = K.marshaled - let equal = K.equal_marshaled - let hash = K.hash_marshaled + type t = K.marshaled + let equal = K.equal_marshaled + let hash = K.hash_marshaled end) type marshaled_value = { data: D.marshaled; - key_name: string; - key_cluster: string option; - data_uname: string; - data_name: string; - data_cluster: string option } + key_name: string; + key_cluster: string option; + data_uname: string; + data_name: string; + data_cluster: string option } type marshaled = (string, marshaled_value) Hashtbl.t H.t @@ -510,20 +510,20 @@ let h : marshaled = H.create 97 in K.Hashtbl.iter (fun key tbl -> - let tbl' = Hashtbl.create 7 in - Internal_tbl.iter - (fun s (d, s') -> - Hashtbl.add - tbl' - (State.get_unique_name s) - { data = data_marshal d; - key_name = State.get_name s; - key_cluster = State.Cluster.name s; - data_uname = State.get_unique_name s'; - data_name = State.get_name s'; - data_cluster = State.Cluster.name s' }) - tbl; - H.add h (key_marshal key) tbl') + let tbl' = Hashtbl.create 7 in + Internal_tbl.iter + (fun s (d, s') -> + Hashtbl.add + tbl' + (State.get_unique_name s) + { data = data_marshal d; + key_name = State.get_name s; + key_cluster = State.Cluster.name s; + data_uname = State.get_unique_name s'; + data_name = State.get_name s'; + data_cluster = State.Cluster.name s' }) + tbl; + H.add h (key_marshal key) tbl') dash.h; h @@ -533,51 +533,51 @@ let inverse = dash.inverse in H.iter (fun key tbl -> - let tbl' = Internal_tbl.create 7 in - let k = key_unmarshal key in - let update s k = - ( Format.printf "updating %S@." (State.get_unique_name s);) - State.update_unusable s k (clear_state_on dash s); - G.add_state s; - in - Hashtbl.iter - (fun - unique_name - { data = d; - key_name = name; - key_cluster = c; - data_uname = unique_name'; - data_name = name'; - data_cluster = c' } - -> - let s = - if unique_name = State.dummy_unique_name then State.dummy - else - try State.get unique_name - with State.Unknown -> State.unusable ~name unique_name - in - State.Cluster.unmarshal c s; - let s' = - assert (unique_name' <> State.dummy_unique_name); - try - let s' = State.get unique_name' in - if not (State.is_usable s') then update s' G.internal_kind; - s' - with State.Unknown -> - let s' = State.unusable ~name:name' unique_name' in - update s' G.internal_kind; - s' - in - State.Cluster.unmarshal c' s'; - let d = data_unmarshal d in - Internal_tbl.add tbl' s (d, s'); - try - let l = State_tbl.find inverse s' in - State_tbl.replace inverse s' ((k, s) :: l) - with Not_found -> - State_tbl.add inverse s' [ k, s ]) - tbl; - K.Hashtbl.add dash_h k tbl') + let tbl' = Internal_tbl.create 7 in + let k = key_unmarshal key in + let update s k = + ( Format.printf "updating %S@." (State.get_unique_name s);*) + State.update_unusable s k (clear_state_on dash s); + G.add_state s; + in + Hashtbl.iter + (fun + unique_name + { data = d; + key_name = name; + key_cluster = c; + data_uname = unique_name'; + data_name = name'; + data_cluster = c' } + -> + let s = + if unique_name = State.dummy_unique_name then State.dummy + else + try State.get unique_name + with State.Unknown -> State.unusable ~name unique_name + in + State.Cluster.unmarshal c s; + let s' = + assert (unique_name' <> State.dummy_unique_name); + try + let s' = State.get unique_name' in + if not (State.is_usable s') then update s' G.internal_kind; + s' + with State.Unknown -> + let s' = State.unusable ~name:name' unique_name' in + update s' G.internal_kind; + s' + in + State.Cluster.unmarshal c' s'; + let d = data_unmarshal d in + Internal_tbl.add tbl' s (d, s'); + try + let l = State_tbl.find inverse s' in + State_tbl.replace inverse s' ((k, s) :: l) + with Not_found -> + State_tbl.add inverse s' [ k, s ]) + tbl; + K.Hashtbl.add dash_h k tbl') h; dash diff -Nru frama-c-20110201+carbon+dfsg/src/project/dashtbl.mli frama-c-20111001+nitrogen+dfsg/src/project/dashtbl.mli --- frama-c-20110201+carbon+dfsg/src/project/dashtbl.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/dashtbl.mli 2011-10-10 08:38:25.000000000 +0000 @@ -34,11 +34,11 @@ type key (** Type of keys of the table. - @since Boron-20100401 ) + @since Boron-20100401 ) type data (** Type of values of the table. - @since Boron-20100401 ) + @since Boron-20100401 ) (** {3 Modifying a table} *) @@ -48,34 +48,34 @@ val add: t -> string -> key -> State.t list -> data -> unit (** Add a new binding [key, data] in the table. - The dependencies are the states required for computing the binding. - More precisely, a binding is a triple [key --> state --> data] and [add - k l d] adds as many bindings as the length of the list, but all these - bindings correspond to the very same state. - - Be aware that [add k [ s1; s2 ] v] is NOT equivalent to [add k [ s1 - ] v; add k [ s2 ] v]. - - In the former, it looks like having only one binding [k, v] in the - table which requires both [s1] and [s2] to be computed. If you clear - the dependencies of [s1], this binding is removed from the table. - - In the latter, it looks like having have two disting bindings [k, v] - in the table. The first one is computed by using [s1] while the second - one (containing the same value) is computed by using [s2]. If you clear - the dependencies of [s1], only the first binding is removed from the - table, but the second one is still present. + The dependencies are the states required for computing the binding. + More precisely, a binding is a triple [key --> state --> data] and [add + k l d] adds as many bindings as the length of the list, but all these + bindings correspond to the very same state. + + Be aware that [add k [ s1; s2 ] v] is NOT equivalent to [add k [ s1 + ] v; add k [ s2 ] v]. + - In the former, it looks like having only one binding [k, v] in the + table which requires both [s1] and [s2] to be computed. If you clear + the dependencies of [s1], this binding is removed from the table. + - In the latter, it looks like having have two disting bindings [k, v] + in the table. The first one is computed by using [s1] while the second + one (containing the same value) is computed by using [s2]. If you clear + the dependencies of [s1], only the first binding is removed from the + table, but the second one is still present. - @modify Carbon-20101201 adding the string argument - @since Boron-20100401 ) + @modify Carbon-20101201 adding the string argument + @since Boron-20100401 ) val replace: reset:bool -> t -> string -> key -> State.t list -> data -> unit (** Similar to [add] but replace the existing bindings if any (same - difference that [Hashtbl.replace] wrt [Hashtbl.add]. - If [reset] to [true], all the dependencies of old bindings are cleared. - It is always safe to put [reset] to [true], but it may be unsafe to - put it to [false]. - [reset] era - @modify Carbon-20101201 adding the string argument - @since Boron-20100401 ) + difference that [Hashtbl.replace] wrt [Hashtbl.add]. + If [reset] to [true], all the dependencies of old bindings are cleared. + It is always safe to put [reset] to [true], but it may be unsafe to + put it to [false]. + [reset] era + @modify Carbon-20101201 adding the string argument + @since Boron-20100401 ) val memo: reset:bool -> (data list -> data) -> t -> string -> key -> State.t list -> @@ -99,38 +99,38 @@ val remove: reset:bool -> t -> key -> State.t -> unit (** Remove all the bindings associated to the given key and state. Do - nothing if there is no such binding. - If [reset] is [true], clear all athe dependencies of the removed - binding. - It is always safe to put [reset] to [true], but it may be unsafe to - put it to [false]. - @since Boron-20100401 ) + nothing if there is no such binding. + If [reset] is [true], clear all athe dependencies of the removed + binding. + It is always safe to put [reset] to [true], but it may be unsafe to + put it to [false]. + @since Boron-20100401 ) val remove_all: reset:bool -> t -> key -> unit (** Remove all the bindings added and associated to the given key. - Do nothing if there is no such binding. - If [reset] is [true], clear all the dependencies of each removed - binding. - It is always safe to put [reset] to [true], but it may be unsafe to - put it to [false]. - @since Boron-20100401 ) + Do nothing if there is no such binding. + If [reset] is [true], clear all the dependencies of each removed + binding. + It is always safe to put [reset] to [true], but it may be unsafe to + put it to [false]. + @since Boron-20100401 ) val filter: reset:bool -> (key -> State.t option -> data -> bool) -> t -> key -> unit (** Remove all the bindings added and associated to the given key and - which does not satisfy the given condition. - Do nothing if there is no such binding. - If [reset] is [true], clear all the dependencies of each removed - binding. - It is always safe to put [reset] to [true], but it may be unsafe to - put it to [false]. - @since Boron-20100401 ) + which does not satisfy the given condition. + Do nothing if there is no such binding. + If [reset] is [true], clear all the dependencies of each removed + binding. + It is always safe to put [reset] to [true], but it may be unsafe to + put it to [false]. + @since Boron-20100401 ) (** {3 Finders} *) val mem: t -> key -> bool (** @return [true] if there is a binding with the given key. - @since Boron-20100401 ) + @since Boron-20100401 ) val is_local: t -> State.t -> bool (** @return [true] if the state corresponds to a binding of the dashtbl. @@ -138,10 +138,10 @@ val find: ?who:State.t list -> t -> key -> State.t -> data * State.t (** Get the binding associated to the given key and state. - if [who] is set, automatically adds dependency from the found state - to each of states of [who]. - @raise Not_found if there is no such binding - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from the found state + to each of states of [who]. + @raise Not_found if there is no such binding + @since Boron-20100401 ) val find_key: t -> State.t -> (key * State.t) list ( Return the keys with their corresponding states which map to the given @@ -150,73 +150,73 @@ val find_data: ?who:State.t list -> t -> key -> State.t -> data ( Get the data associated to the given key and state. - if [who] is set, automatically adds dependency from the state - corresponding to the given data to each of states of [who]. - @raise Not_found if there is no such binding - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from the state + corresponding to the given data to each of states of [who]. + @raise Not_found if there is no such binding + @since Boron-20100401 ) val find_state: ?who:State.t list -> t -> key -> State.t -> State.t (** Get the state associated to the given key and state. - if [who] is set, automatically adds dependency from the found state - to each of states of [who]. - @raise Not_found if there is no such binding - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from the found state + to each of states of [who]. + @raise Not_found if there is no such binding + @since Boron-20100401 ) val find_all_local: ?who:State.t list -> t -> key -> State.t -> (data * State.t) list (** Get all the bindings associated to the given key and state. - if [who] is set, automatically adds dependency from each found state - to each of states of [who]. - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from each found state + to each of states of [who]. + @since Boron-20100401 ) val find_all_local_data: ?who:State.t list -> t -> key -> State.t -> data list (** Get all the data associated to the given key and state. - if [who] is set, automatically adds dependency from the state - corresponding to each data to each of states of [who]. - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from the state + corresponding to each data to each of states of [who]. + @since Boron-20100401 ) val find_all_local_states: ?who:State.t list -> t -> key -> State.t -> State.t list (** Get all the states associated to the given key and state. - if [who] is set, automatically adds dependency from each found state - to each of states of [who]. - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from each found state + to each of states of [who]. + @since Boron-20100401 ) val find_all: ?who:State.t list -> t -> key -> (data * State.t) list (** Get all bindings associated to the given key. - if [who] is set, automatically adds dependency from each found state - to each of states of [who]. - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from each found state + to each of states of [who]. + @since Boron-20100401 ) val find_all_data: ?who:State.t list -> t -> key -> data list (** Get all data associated to the given key. - if [who] is set, automatically adds dependency from the state - correspondin to of each found data to each of states of [who]. - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from the state + correspondin to of each found data to each of states of [who]. + @since Boron-20100401 ) val find_all_states: ?who:State.t list -> t -> key -> State.t list (** Get all states associated to the given key. - if [who] is set, automatically adds dependency from each found state - to each of states of [who]. - @since Boron-20100401 ) + if [who] is set, automatically adds dependency from each found state + to each of states of [who]. + @since Boron-20100401 ) (** {3 Iterators} ) val iter: (key -> State.t option -> data State.t -> unit) -> t -> unit (** Iterator on each binding of the table. - @since Boron-20100401 + @since Boron-20100401 @modify Carbon-20101201 ) val iter_key: (State.t option -> data State.t -> unit) -> t -> key -> unit (** Iterator on each binding of the table associated to the given key. - @since Boron-20100401 + @since Boron-20100401 @modify Carbon-20101201 ) val fold: (key -> State.t option -> data State.t -> 'a -> 'a) -> t -> 'a -> 'a (** Folder on each binding of the table. - @since Boron-20100401 + @since Boron-20100401 @modify Carbon-20101201 *) val fold_key: @@ -229,7 +229,7 @@ val length: t -> int (** Number of bindings in the table. - @since Boron-20100401 ) + @since Boron-20100401 ) type marshaled val marshaler: (t -> marshaled) * (marshaled -> t) diff -Nru frama-c-20110201+carbon+dfsg/src/project/project.ml frama-c-20111001+nitrogen+dfsg/src/project/project.ml --- frama-c-20110201+carbon+dfsg/src/project/project.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/project.ml 2011-10-10 08:38:25.000000000 +0000 @@ -41,10 +41,10 @@ type t = project let name = "Project" let structural_descr = - Structural_descr.t_record - [| Structural_descr.p_int; - Structural_descr.p_string; - Structural_descr.p_string |] + Structural_descr.t_record + [| Structural_descr.p_int; + Structural_descr.p_string; + Structural_descr.p_string |] let reprs = [ dummy ] let equal = (==) let compare p1 p2 = Datatype.Int.compare p1.pid p2.pid @@ -52,11 +52,11 @@ let rehash x = !rehash_ref x let copy = Datatype.undefined let internal_pretty_code p_caller fmt p = - let pp f = - Format.fprintf - f "@[<hv 2>Project.from_unique_name@;%S@]" p.unique_name - in - Type.par p_caller Type.Call fmt pp + let pp f = + Format.fprintf + f "@[<hv 2>Project.from_unique_name@;%S@]" p.unique_name + in + Type.par p_caller Type.Call fmt pp let pretty fmt p = Format.fprintf fmt "project %S" p.unique_name let varname p = "p_" ^ p.name let mem_project f x = f x @@ -69,6 +69,9 @@ (** {2 States operations} ) ( ************************************************************************** ) +let current_selection = ref State_selection.empty +let get_current_selection () = !current_selection + module States_operations = struct module H = Hashtbl @@ -76,19 +79,17 @@ module Hashtbl = H let iter f x = + current_selection := State_selection.full; State_dependency_graph.Static.G.iter_vertex (fun s -> f s x) State_dependency_graph.Static.graph - let fold f x = - State_dependency_graph.Static.G.fold_vertex - (fun s -> f s x) - State_dependency_graph.Static.graph - let iter_on_selection ?(selection=State_selection.full) f x = + current_selection := selection; State_selection.Static.iter (fun s -> f s x) selection let fold_on_selection ?(selection=State_selection.full) f x = + current_selection := selection; State_selection.Static.fold (fun s -> f s x) selection let create = iter (fun s -> (private_ops s).create) @@ -105,33 +106,35 @@ let clear s = (private_ops s).clear in if State_selection.is_full selection then iter clear p ( clearing the static states also clears the dynamic ones ) - else + else begin + current_selection := selection; State_selection.Dynamic.iter (fun s -> clear s p) selection + end let clear_some_projects ?selection f p = let states_to_clear = fold_on_selection - ?selection - (fun s p acc -> - let is_cleared = (private_ops s).clear_some_projects f p in - if is_cleared then - State_selection.Dynamic.union - (State_selection.Dynamic.with_dependencies s) - acc - else - acc) - p - State_selection.empty + ?selection + (fun s p acc -> + let is_cleared = (private_ops s).clear_some_projects f p in + if is_cleared then + State_selection.Dynamic.union + (State_selection.Dynamic.with_dependencies s) + acc + else + acc) + p + State_selection.empty in if not (State_selection.is_empty states_to_clear) then begin warning "clearing dangling project pointers in project %S" p.unique_name; debug ~once:true ~append:(fun fmt -> Format.fprintf fmt "@]") - "@[the involved states are:%t" - (fun fmt -> - iter_on_selection - ~selection:states_to_clear - (fun s () -> Format.fprintf fmt "@ %S" (get_name s)) - ()) + "@[the involved states are:%t" + (fun fmt -> + iter_on_selection + ~selection:states_to_clear + (fun s () -> Format.fprintf fmt "@ %S" (get_name s)) + ()) end let copy ?selection src = @@ -147,11 +150,11 @@ let unserialize ?selection dst loaded_states = let pp_err fmt n = if n > 0 then begin - warning ~once:true - fmt - n - (if n = 1 then "" else "s") (if n = 1 then "is" else "are") - (if n = 1 then "It does not exist in" else "They do not exist in") + warning ~once:true + fmt + n + (if n = 1 then "" else "s") (if n = 1 then "is" else "are") + (if n = 1 then "It does not exist in" else "They do not exist in") end in let tbl = Hashtbl.create 97 in @@ -159,20 +162,20 @@ iter_on_selection ?selection (fun s () -> - try - let n = get_unique_name s in - let d = Hashtbl.find tbl n in - (try (private_ops s).unserialize dst d - with Not_found -> assert false); - Hashtbl.remove tbl n; - with Not_found -> - ( [s] is in RAM but not on disk: silently ignore it! - As [dst] is a new project, [s] is already equal to its default - value. Furthermore, all the dependencies of [s] are consistent - with this default value. So no need to clear them. Whenever - the value of [s] in [dst] changes, the dependencies will be - cleared (if required by the user of Project.clear). ) - ()) + try + let n = get_unique_name s in + let d = Hashtbl.find tbl n in + (try (private_ops s).unserialize dst d + with Not_found -> assert false); + Hashtbl.remove tbl n; + with Not_found -> + ( [s] is in RAM but not on disk: silently ignore it! + As [dst] is a new project, [s] is already equal to its default + value. Furthermore, all the dependencies of [s] are consistent + with this default value. So no need to clear them. Whenever + the value of [s] in [dst] changes, the dependencies will be + cleared (if required by the user of Project.clear). ) + ()) (); ( warns for the saved states that cannot be loaded. ) let nb_ignored = @@ -195,17 +198,17 @@ else let n = get_size selection in if n = 0 then - Log.nullprintf fmt_msg + Log.nullprintf fmt_msg else - let states fmt = - if n > 1 then Format.fprintf fmt " (for %d states)" n - else Format.fprintf fmt " (for 1 state)"; - if debug_atleast 1 then begin - Format.pp_print_newline fmt (); - pp_selection fmt selection - end - in - feedback ~level ~append:states fmt_msg + let states fmt = + if n > 1 then Format.fprintf fmt " (for %d states)" n + else Format.fprintf fmt " (for 1 state)"; + if debug_atleast 1 then begin + Format.pp_print_newline fmt (); + pp_selection fmt selection + end + in + feedback ~level ~append:states fmt_msg else Log.nullprintf fmt_msg @@ -319,7 +322,7 @@ Journal.register "Project.set_current" (lbl "on" (fun () -> false) Datatype.bool (lbl "selection" dft_sel State_selection.ty - (Datatype.func ty Datatype.unit))) + (Datatype.func ty Datatype.unit))) unjournalized_set_current let set_current ?(on=false) ?(selection=State_selection.full) p = @@ -389,7 +392,7 @@ (lbl "src" current ty (Datatype.func ty Datatype.unit))) (fun selection src dst -> guarded_feedback selection 2 "copying project from %S to %S" - src.unique_name dst.unique_name; + src.unique_name dst.unique_name; States_operations.commit ~selection src; States_operations.copy ~selection src dst) @@ -413,7 +416,7 @@ (lbl "project" current ty (Datatype.func Datatype.unit Datatype.unit))) (fun selection project () -> full_guarded_feedback selection 2 "clearing project %S" - project.unique_name; + project.unique_name; Before_Clear_Hook.apply project; States_operations.clear ~selection project; After_Clear_Hook.apply project; @@ -458,11 +461,11 @@ output_value cout !Graph.Blocks.cpt_vertex; let states : (t (string * State.state_on_disk) list) list = Q.fold - (fun acc p -> - (* project + serialized version of all its states ) - (p, States_operations.serialize ~selection p) :: acc) - [] - projects + (fun acc p -> + ( project + serialized version of all its states ) + (p, States_operations.serialize ~selection p) :: acc) + [] + projects in ( projects are stored on disk from the current one to the last project ) output_value cout (List.rev states); @@ -512,19 +515,19 @@ module Rehash = Hashtbl.Make (struct - type t = project - let hash p = Hashtbl.hash p.pid - let equal x y = - match !project_under_copy_ref with - | Some p when p.pid <> x.pid && p.pid <> y.pid -> - ( Merge projects on disk with pre-existing projects, except the - project under copy; so don't use (==) in this context. ) - x.pid = y.pid - | None | Some _ -> - ( In all other cases, don't merge. - (==) ensures that there is no sharing between a pre-existing - project and a project on disk. Great! ) - x == y + type t = project + let hash p = Hashtbl.hash p.pid + let equal x y = + match !project_under_copy_ref with + | Some p when p.pid <> x.pid && p.pid <> y.pid -> + ( Merge projects on disk with pre-existing projects, except the + project under copy; so don't use (==) in this context. ) + x.pid = y.pid + | None | Some _ -> + ( In all other cases, don't merge. + (==) ensures that there is no sharing between a pre-existing + project and a project on disk. Great! ) + x == y end) let rehash_cache : project Rehash.t = Rehash.create 7 @@ -542,7 +545,7 @@ let init project_under_copy = assert (Rehash.length rehash_cache = 0 - && Project_tbl.length existing_projects = 0); + && Project_tbl.length existing_projects = 0); project_under_copy_ref := project_under_copy; Q.fold (fun acc p -> Project_tbl.add existing_projects p (); p :: acc) @@ -553,12 +556,12 @@ (match !project_under_copy_ref with | None -> List.iter - (fun ( (p, _)) -> - States_operations.clear_some_projects - ~selection - (fun p -> not (Project_tbl.mem existing_projects p)) - p) - loaded_states + (fun ( (p, _)) -> + States_operations.clear_some_projects + ~selection + (fun p -> not (Project_tbl.mem existing_projects p)) + p) + loaded_states | Some _ -> ()); Rehash.clear rehash_cache; @@ -568,41 +571,41 @@ let state_on_disk s = ( Format.printf "State %S@." s;) let descr = - try State.get_descr (State.get s) - with State.Unknown -> Structural_descr.p_unit ( dummy value ) + try State.get_descr (State.get s) + with State.Unknown -> Structural_descr.p_unit ( dummy value ) in Descr.t_record - [| descr; - Structural_descr.p_bool; - Structural_descr.p_bool; - Structural_descr.p_string |] - State.dummy_state_on_disk + [| descr; + Structural_descr.p_bool; + Structural_descr.p_bool; + Structural_descr.p_string |] + State.dummy_state_on_disk in let tbl_on_disk = Descr.dependent_pair Descr.t_string state_on_disk in let one_state = let unmarshal_states p = - Descr.dynamic - (fun () -> - ( Local states must be up-to-date according [p] when unmarshalling - states of [p] ) - unjournalized_set_current true selection p; - Before_load.apply (); - Descr.t_list tbl_on_disk) + Descr.dynamic + (fun () -> + ( Local states must be up-to-date according [p] when unmarshalling + states of [p] ) + unjournalized_set_current true selection p; + Before_load.apply (); + Descr.t_list tbl_on_disk) in Descr.dependent_pair descr unmarshal_states in let final_one_state = Descr.transform - one_state - (fun (p, s as c) -> - (match name with None -> () | Some s -> set_name p s); - Project_tbl.add existing_projects p (); - ( At this point, the local states are always up-to-date according - to the current project, since we load first the old current - project ) - States_operations.unserialize ~selection p s; - After_load.apply (); - c) + one_state + (fun (p, s as c) -> + (match name with None -> () | Some s -> set_name p s); + Project_tbl.add existing_projects p (); + ( At this point, the local states are always up-to-date according + to the current project, since we load first the old current + project ) + States_operations.unserialize ~selection p s; + After_load.apply (); + c) in Descr.t_list final_one_state @@ -620,14 +623,14 @@ let check_magic cin to_string current = let old = read cin in if old <> current then begin - close_in cin; - let s = - Format.sprintf - "project saved with an incompatible version (old: %S,current: %S)" - (to_string old) - (to_string current) - in - raise (IOError s) + close_in cin; + let s = + Format.sprintf + "project saved with an incompatible version (old: %S,current: %S)" + (to_string old) + (to_string current) + in + raise (IOError s) end in check_magic cin (fun x -> x) Config.version; @@ -636,31 +639,31 @@ let pre_existing_projects = Descr.init project_under_copy in let loaded_states = gen_read - (fun c -> Descr.input_val c (Descr.global_state name selection)) - cin + (fun c -> Descr.input_val c (Descr.global_state name selection)) + cin in close_in cin; Descr.finalize loaded_states selection; Graph.Blocks.after_unserialization ocamlgraph_counter; - After_global_load.apply (); ( [set_current] done when unmarshalling and hooks may reorder projects: rebuild it in the good order ) let last = current () in Q.clear projects; let loaded_projects = List.fold_right - (fun (p, _) acc -> Q.add p projects; p :: acc) loaded_states [] + (fun (p, _) acc -> Q.add p projects; p :: acc) loaded_states [] in List.iter (fun p -> Q.add p projects) pre_existing_projects; ( We have to restore all the local states if the last loaded project is not the good current one. The trick is to call [set_current] on [current - ()], but we ensure that this operations do something (that is not + ()], but we ensure that this operation does something (that is not the case by default) by putting [last] as current project temporarily. *) let true_current = current () in Q.add last projects; unjournalized_set_current true selection true_current; Q.remove last projects; + After_global_load.apply (); loaded_projects end else abort "loading a file is not supported in the 'no obj' mode" @@ -677,7 +680,7 @@ Journal.register "Project.load" (lbl "selection" dft_sel State_selection.ty (lbl "name" (fun () -> None) - (Datatype.option Datatype.string) (Datatype.func Datatype.string ty))) + (Datatype.option Datatype.string) (Datatype.func Datatype.string ty))) (unjournalized_load ~project_under_copy:None) let load ?(selection=State_selection.full) ?name filename = @@ -709,12 +712,15 @@ let unjournalized_create_by_copy selection src name = guarded_feedback selection 2 "creating project %S by copying project %S" name (src.unique_name); - let filename = Filename.temp_file "frama_c_create_by_copy" ".sav" in + let filename = + try Filename.temp_file "frama_c_create_by_copy" ".sav" + with Sys_error s -> abort "cannot create temporary file: %s" s + in save ~selection ~project:src filename; try let prj = unjournalized_load - ~project_under_copy:(Some src) selection (Some name) filename + ~project_under_copy:(Some src) selection (Some name) filename in Extlib.safe_remove filename; Create_by_copy_hook.apply (src, prj); @@ -747,18 +753,20 @@ let restore () = if Cmdline.use_obj then begin try - Journal.prevent load_all !filename; - Journal.restore (); - clear_breakpoint () + Journal.prevent load_all !filename; + Journal.restore (); + clear_breakpoint () with IOError s -> - feedback "cannot restore the last breakpoint: %S" s; - clear_breakpoint () + feedback "cannot restore the last breakpoint: %S" s; + clear_breakpoint () end let breakpoint () = if Cmdline.use_obj then begin clear_breakpoint (); - filename := Filename.temp_file short_filename ".sav"; + filename := + (try Filename.temp_file short_filename ".sav" + with Sys_error s -> abort "cannot create temporary file: %s" s); Journal.prevent save_all !filename; Journal.save () end diff -Nru frama-c-20110201+carbon+dfsg/src/project/project.mli frama-c-20111001+nitrogen+dfsg/src/project/project.mli --- frama-c-20110201+carbon+dfsg/src/project/project.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/project.mli 2011-10-10 08:38:25.000000000 +0000 @@ -40,10 +40,10 @@ type project = Project_skeleton.t = private { pid : int; - mutable name : string; - mutable unique_name : string } + mutable name : string; + mutable unique_name : string } (** Type of a project. - @plugin development guide ) + @plugin development guide ) (* ************************************************************************* *) (** {2 Operations on all projects} *) @@ -258,10 +258,20 @@ val register_after_global_load_hook: (unit -> unit) -> unit ( [register_after_load_hook f] adds a hook called just after loading - all projects. + all projects**. [f] must not set the current project. @since Boron-20100401 ) ( ************************************************************************* *) +(** {3 Handling the selection} ) +( ************************************************************************* *) + +val get_current_selection: unit -> State_selection.t +(** If an operation on a project is ongoing, then [get_current_selection ()] + returns the selection which is applied on. + The behaviour is unspecified if this function is called when no operation + depending on a selection is ongoing. ) + +( ************************************************************************* *) (** {2 Projects are comparable values} ) ( ************************************************************************* *) diff -Nru frama-c-20110201+carbon+dfsg/src/project/project_skeleton.mli frama-c-20111001+nitrogen+dfsg/src/project/project_skeleton.mli --- frama-c-20110201+carbon+dfsg/src/project/project_skeleton.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/project_skeleton.mli 2011-10-10 08:38:25.000000000 +0000 @@ -51,6 +51,10 @@ (** @since Carbon-20101201 *) module Make_setter(X: sig val mem: string -> bool end) : sig + val make_unique_name: string -> string + (** @return a fresh name from the given string according to [X.mem]. + @since Nitrogen-20111001 *) + val make: string -> t (** @since Carbon-20101201 ) diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_builder.ml frama-c-20111001+nitrogen+dfsg/src/project/state_builder.ml --- frama-c-20110201+carbon+dfsg/src/project/state_builder.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_builder.ml 2011-10-10 08:38:25.000000000 +0000 @@ -44,6 +44,7 @@ val mark_as_computed: ?project:Project.t -> unit -> unit val is_computed: ?project:Project.t -> unit -> bool module Datatype: Datatype.S + val add_hook_on_update: (Datatype.t -> unit) -> unit val howto_marshal: (Datatype.t -> 'a) -> ('a -> Datatype.t) -> unit end @@ -80,25 +81,26 @@ let create name kind correctness states = let s = State.create - ~descr:Structural_descr.p_abstract - ~create:do_nothing - ~remove:do_nothing - ~clear:do_nothing - ~clean:do_nothing - ~clear_some_projects:(fun _ _ -> false) - ~copy:do_nothing_2 - ~commit:do_nothing - ~update:do_nothing - ~serialize: - (fun _ -> - { on_disk_value = Obj.repr (); - on_disk_computed = false; - on_disk_saved = false; - on_disk_digest = Type.digest Datatype.unit }) - ~unserialize:do_nothing_2 - ~unique_name:name - ~name - (`Proxy correctness) + ~descr:Structural_descr.p_abstract + ~create:do_nothing + ~remove:do_nothing + ~clear:do_nothing + ~clean:do_nothing + ~clear_some_projects:(fun _ _ -> false) + ~copy:do_nothing_2 + ~commit:do_nothing + ~update:do_nothing + ~on_update:do_nothing + ~serialize: + (fun _ -> + { on_disk_value = Obj.repr (); + on_disk_computed = false; + on_disk_saved = false; + on_disk_digest = Type.digest Datatype.unit }) + ~unserialize:do_nothing_2 + ~unique_name:(State.unique_name_from_name name) + ~name + (`Proxy correctness) in State_dependency_graph.add_state_like_the_others states s; extend_state states kind s; @@ -141,18 +143,22 @@ let commit p = if Project.is_current p then try - let v = find p in - v.state <- Local_state.get () + let v = find p in + v.state <- Local_state.get () with Not_found -> - fatal - "state %S not associated with project %S; program will fail" - name - (Project.get_unique_name p) + fatal + "state %S not associated with project %S; program will fail" + name + (Project.get_unique_name p) + + module Update_hook = Hook.Build(Datatype) + let add_hook_on_update = Update_hook.extend let update_with ~force p s = if Project.is_current p || force then begin debug ~level:4 "update state %S of project %S" - !internal_name (Project.get_unique_name p); + !internal_name (Project.get_unique_name p); + Update_hook.apply s; Local_state.set s end @@ -174,17 +180,17 @@ fun p -> assert (not (mem p)); ( For efficiency purpose, do not create the initial project twice: - directly get it ) + directly get it ) let mk () = - if !first then begin - first := false; - Local_state.get () - end else begin + if !first then begin + first := false; + Local_state.get () + end else begin debug ~level:4 "creating state %S for project %S" - !internal_name (Project.get_unique_name p); - let s = Local_state.create () in - update_with ~force:false p s; - s + !internal_name (Project.get_unique_name p); + let s = Local_state.create () in + update_with ~force:false p s; + s end in let s = mk () in @@ -239,23 +245,23 @@ assert Cmdline.use_obj; if Type.digest Datatype.ty = new_s.State.on_disk_digest then begin debug ~level:4 "unserializing state %S for project %S" - !internal_name (Project.get_unique_name p); + !internal_name (Project.get_unique_name p); (* Format.printf "UNSERIALIZING %s / %s: %b@." !internal_name Datatype.name !must_save;) let s, computed = - if !must_save && new_s.State.on_disk_saved then - !unmarshal new_s.State.on_disk_value, new_s.State.on_disk_computed - else - ( invariant: the found state is equal to the default one since it - has been just created. - Do not call Local_state.create to don't break sharing ) - (find p).state, false + if !must_save && new_s.State.on_disk_saved then + !unmarshal new_s.State.on_disk_value, new_s.State.on_disk_computed + else + ( invariant: the found state is equal to the default one since it + has been just created. + Do not call Local_state.create to don't break sharing ) + (find p).state, false in change ~force:true p { state = s; computed = computed }; end else raise - (Project.IOError - ("project saved with incompatibles datatypes for state " - ^ !internal_name)) + (Project.IOError + ("project saved with incompatibles datatypes for state " + ^ !internal_name)) ( ********************************************************************* ) let mark_as_computed ?(project=(Project.current ())) () = @@ -271,7 +277,8 @@ State.create ( we will marshal the value [()] if the state is unmarshable ) ~descr ~create ~remove ~clear ~clear_some_projects ~copy - ~commit ~update ~serialize ~unserialize ~clean + ~commit ~update ~on_update:(fun f -> Update_hook.extend (fun _ -> f ())) + ~serialize ~unserialize ~clean ~unique_name ~name:Info.name Info.kind let name = State.get_name self @@ -345,7 +352,7 @@ let new_kind ~name unique_name clear = let clear p = debug ~level:4 "clearing dynamic state %S for project %S" - name (Project.get_unique_name p); + name (Project.get_unique_name p); clear p in let s = State.unusable ~name unique_name in @@ -359,9 +366,9 @@ (G.Datatype) (G) (struct - include Info - let unique_name = name - let descr _ = Descr.unmarshable + include Info + let unique_name = name + let descr _ = Descr.unmarshable end) let () = Proxy.extend [ Graph_state.self ] states_graph_proxy @@ -388,8 +395,8 @@ let kind = State.kind self let () = let deps = - !self_ref - :: List.filter (fun s -> not (State.is_dummy s)) Info.dependencies + !self_ref + :: List.filter (fun s -> not (State.is_dummy s)) Info.dependencies in G.add_state self deps end @@ -478,7 +485,7 @@ try let old = get () in Extlib.may_map - ~dft:old (fun f -> let v = f old in set v; v) change + ~dft:old (fun f -> let v = f old in set v; v) change with Not_found -> let data = f () in set data; @@ -492,6 +499,7 @@ module type List_ref = sig type data_in_list include Ref + val add: data_in_list -> unit val iter: (data_in_list -> unit) -> unit val fold_left: ('a -> data_in_list -> 'a) -> 'a -> 'a end @@ -499,6 +507,7 @@ module List_ref(Data:Datatype.S)(Info:Info) = struct type data_in_list = Data.t include Ref(Datatype.List(Data))(struct include Info let default () = [] end) + let add d = set (d::get()) let iter f = List.iter f (get ()) let fold_left f acc = List.fold_left f acc (get ()) end @@ -523,7 +532,7 @@ ( ************************************************************************* ) module type Set_ref = sig - include S + include Ref type elt val add: elt -> unit val is_empty: unit -> bool @@ -593,21 +602,21 @@ ( Format.printf "%S: %S %S@." Info.name H.Key.name Data.name;) let x = if D.mem_project == Datatype.never_any_project then - false + false else - ( [TODO] BUG: if [Data.mem_project f v] returns [true] and there are - several bindings for the key [k] of [v] (and [v] is not the last - added binding) ) - let found = - H.fold - (fun k v l -> - if H.Key.mem_project f k || Data.mem_project f v then k :: l - else l) - h - [] - in - List.iter (H.remove h) found; - found <> [] + ( [TODO] BUG: if [Data.mem_project f v] returns [true] and there are + several bindings for the key [k] of [v] (and [v] is not the last + added binding) ) + let found = + H.fold + (fun k v l -> + if H.Key.mem_project f k || Data.mem_project f v then k :: l + else l) + h + [] + in + List.iter (H.remove h) found; + found <> [] in ( Format.printf "DONE@.";) x @@ -629,7 +638,7 @@ try let old = find key in Extlib.may_map - ~dft:old (fun f -> let v = f old in replace key v; v) change + ~dft:old (fun f -> let v = f old in replace key v; v) change with Not_found -> let data = f key in replace key data; @@ -678,14 +687,14 @@ let set x = state := x let clear_some_projects f h = if Data.mem_project == Datatype.never_any_project then - false + false else - let found = - W.fold - (fun k l -> if Data.mem_project f k then k :: l else l) h [] - in - List.iter (W.remove h) found; - found <> [] + let found = + W.fold + (fun k l -> if Data.mem_project f k then k :: l else l) h [] + in + List.iter (W.remove h) found; + found <> [] end) (struct include Info let unique_name = name end) @@ -721,20 +730,20 @@ include Weak.Make (struct - include Data - let equal = Data.equal_internal - let hash = Data.hash_internal + include Data + let equal = Data.equal_internal + let hash = Data.hash_internal end) let add_initial_values h = ( Format.printf "adding initial values for %s@." Info.name;) List.iter - (fun vi -> - let _r = merge h vi in - ( (* Check that we do not add the value twice, which is probably a - bug in the calling interface ) - assert (r == vi) ) ()) - Data.initial_values + (fun vi -> + let _r = merge h vi in + (* (* Check that we do not add the value twice, which is probably a + bug in the calling interface ) + assert (r == vi) ) ()) + Data.initial_values let create size = let h = create size in @@ -749,16 +758,16 @@ let merge = let c = ref 0 in fun h x -> - incr c; - if (!c land 4095 = 0) - then begin - Gc.full_major (); - let length, n, sum, small, med, large = stats h in - Format.printf "%s length %d, n %d, sum %d, small %d, med %d, large %d@." - Info.name - length n sum small med large - end; - merge h x + incr c; + if (!c land 4095 = 0) + then begin + Gc.full_major (); + let length, n, sum, small, med, large = stats h in + Format.printf "%s length %d, n %d, sum %d, small %d, med %d, large %d@." + Info.name + length n sum small med large + end; + merge h x ) end @@ -806,43 +815,85 @@ module Graph: Dashtbl.Graph end + ( Create a fresh, shared reference among projects. The projectification is only required for correct marshalling. ) -module Counter(Info : sig val name : string end) = -struct +module SharedCounter(Info : sig val name : string end) = struct + let cpt = ref 0 module Cpt = Register (struct - include Datatype.Int - let default () = 0 - let descr = - Descr.transform - Descr.t_int - (fun n -> - cpt := Extlib.max_cpt n !cpt; - !cpt) + include Datatype.Int + let default () = 0 + let descr = + Descr.transform + Descr.t_int + (fun n -> + cpt := Extlib.max_cpt n !cpt; + !cpt) end) (struct - type t = int - let create () = !cpt - let clear _ = () - let get () = !cpt - let set _ = () - let clear_some_projects _ _ = false + type t = int + let create () = !cpt + let clear _ = () + let get () = !cpt + let set _ = () + let clear_some_projects _ _ = false end) (struct - let name = Info.name - let unique_name = Info.name - let dependencies = [] - let kind = `Internal + let name = Info.name + let unique_name = Info.name + let dependencies = [] + let kind = `Internal end) let next () = incr cpt ; !cpt + let self = Cpt.self + +end + +module Cpt = SharedCounter(struct let name = "State_builder.Cpt" end) + + +module Counter(Info : sig val name : string end) = struct + + let create () = ref 0 + let cpt = ref (create ()) + + module Cpt = + Register + (struct + include Datatype.Ref(Datatype.Int) + let default () = 0 + let descr = + Descr.transform + (Descr.t_ref Descr.t_int) + (fun n -> + let r = !cpt in + r := Extlib.max_cpt !n !r; + r) + end) + (struct + type t = int ref + let create = create + let clear x = x := 0 + let get () = !cpt + let set x = cpt := x + let clear_some_projects _ _ = false + end) + (struct + let name = Info.name + let unique_name = Info.name + let dependencies = [] + let kind = `Internal + end) + + let next () = incr !cpt ; !(!cpt) + let self = Cpt.self end -module Cpt = Counter(struct let name = "State_builder.Cpt" end) module Dashtbl (Key: Dashtbl.Key) @@ -855,24 +906,24 @@ module D = Dynamic - (struct - let name = Info.name ^ " Dependency Graph" - let dependencies = [] - let kind = `Internal - let internal_kind = Info.internal_kind - end) + (struct + let name = Info.name ^ " Dependency Graph" + let dependencies = [] + let kind = `Internal + let internal_kind = Info.internal_kind + end) let create_and_add_state ~clear ~name ~deps = let module S = - D.Register - (struct let clear = clear end) - (struct - let name = name - let unique_name = - let n = Cpt.next () in - Info.name ^ "; binding " ^ string_of_int n - let dependencies = deps - end) + D.Register + (struct let clear = clear end) + (struct + let name = name + let unique_name = + let n = Cpt.next () in + Info.name ^ "; binding " ^ string_of_int n + let dependencies = deps + end) in S.self @@ -902,7 +953,7 @@ let clear_some_projects _ _ = ( TODO: not able to handle project in dashtbl yet ) assert (Data.mem_project == Datatype.never_any_project - || Data.mem_project == Datatype.undefined); + || Data.mem_project == Datatype.undefined); false end) (struct include Info let unique_name = name end) @@ -919,16 +970,16 @@ let () = Project.register_after_load_hook (fun () -> - Dash.iter - (fun _ s (_, s') -> - assert (not (State.is_dummy s')); - let from = - match s with - | None -> [ self ] - | Some s -> [ s; self ] - in - State_dependency_graph.Dynamic.add_codependencies ~onto:s' from) - !state) + Dash.iter + (fun _ s (_, s') -> + assert (not (State.is_dummy s')); + let from = + match s with + | None -> [ self ] + | Some s -> [ s; self ] + in + State_dependency_graph.Dynamic.add_codependencies ~onto:s' from) + !state) type key = Dash.key type data = Dash.data @@ -987,15 +1038,15 @@ let set x = state := x let clear_some_projects f q = if Data.mem_project == Datatype.never_any_project then - false + false else - ( cannot remove a single element from a queue ) - try - Queue.iter (fun x -> if Data.mem_project f x then raise Exit) q; - false - with Exit -> - clear q; - true + ( cannot remove a single element from a queue *) + try + Queue.iter (fun x -> if Data.mem_project f x then raise Exit) q; + false + with Exit -> + clear q; + true end) (struct include Info let unique_name = name end) @@ -1013,8 +1064,8 @@ let module First = True_ref (struct - let dependencies = dep - let name = name + let dependencies = dep + let name = name let kind = `Internal end) in @@ -1022,11 +1073,11 @@ if First.get () then begin First.set false; try - f (); - assert (First.get () = false) + f (); + assert (First.get () = false) with exn -> - First.set true; - raise exn + First.set true; + raise exn end), First.self diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_builder.mli frama-c-20111001+nitrogen+dfsg/src/project/state_builder.mli --- frama-c-20110201+carbon+dfsg/src/project/state_builder.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_builder.mli 2011-10-10 08:38:25.000000000 +0000 @@ -50,7 +50,7 @@ val self: State.t (** The kind of the registered state. - @plugin development guide ) + @plugin development guide ) val name: string val kind: State.kind @@ -67,13 +67,18 @@ module Datatype: Datatype.S + val add_hook_on_update: (Datatype.t -> unit) -> unit + (** Add an hook which is applied each time (just before) the project library + changes the local value of the state. + @since Nitrogen-20111001 *) + val howto_marshal: (Datatype.t -> 'a) -> ('a -> Datatype.t) -> unit - (** [howto_marshal marshal unmarshal] registers a custom couple of - countions [(marshal, unmarshal)] to be used for serialization. - Default functions are identities. In particular, calling this - function must be used if [Datatype.t] is not marshallable and - [do_not_save] is not called. - @since Boron-20100401 *) +(** [howto_marshal marshal unmarshal] registers a custom couple of + countions [(marshal, unmarshal)] to be used for serialization. + Default functions are identities. In particular, calling this + function must be used if [Datatype.t] is not marshallable and + [do_not_save] is not called. + @since Boron-20100401 *) end @@ -125,8 +130,8 @@ include Ref val memo: ?change:(data -> data) -> (unit -> data) -> data (** Memoization. Compute on need the stored value. - If the data is already computed (i.e. is not [None]), - it is possible to change with [change]. ) + If the data is already computed (i.e. is not [None]), + it is possible to change with [change]. ) val map: (data -> data) -> data option val may: (data -> unit) -> unit val get_option : unit -> data option @@ -142,6 +147,7 @@ module type List_ref = sig type data_in_list include Ref + val add: data_in_list -> unit (** @since Nitrogen-20111001 *) val iter: (data_in_list -> unit) -> unit val fold_left: ('a -> data_in_list -> 'a) -> 'a -> 'a end @@ -184,12 +190,12 @@ module type Dashtbl = sig include S (** A dashtable is a standard computation. - BUT: - - that is INCORRECT to add the [self] value of a dashtbl into a - selection without also adding all the {!selection}. - - that is INCORRECT to use dashtable if keys or values have a custom - [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) - @since Boron-20100401 ) + BUT: + - that is INCORRECT to add the [self] value of a dashtbl into a + selection without also adding all the {!selection}. + - that is INCORRECT to use dashtable if keys or values have a custom + [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) + @since Boron-20100401 ) type key type data @@ -244,30 +250,30 @@ include S (** Hashtbl are a standard computation. - BUT it is INCORRECT to use projectified hashtables if keys have a - custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) ) + BUT it is INCORRECT to use projectified hashtables if keys have a + custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) ) type data (** @since Boron-20100401 *) val merge: data -> data (** [merge x] returns an instance of [x] found in the table if any, or else - adds [x] and return [x]. - @since Boron-20100401 ) + adds [x] and return [x]. + @since Boron-20100401 ) val add: data -> unit (** [add x] adds [x] to the table. If there is already an instance of [x], - it is unspecified which one will be returned by subsequent calls to - [find] and [merge]. - @since Boron-20100401 ) + it is unspecified which one will be returned by subsequent calls to + [find] and [merge]. + @since Boron-20100401 ) val clear: unit -> unit (** Clear the table. - @since Boron-20100401 ) + @since Boron-20100401 ) val count: unit -> int (** Length of the table. - @since Boron-20100401 ) + @since Boron-20100401 ) val iter: (data -> unit) -> unit (** @since Boron-20100401 *) @@ -277,22 +283,22 @@ val find: data -> data (** [find x] returns an instance of [x] found in table. - @Raise Not_found if there is no such element. - @since Boron-20100401 ) + @Raise Not_found if there is no such element. + @since Boron-20100401 ) val find_all: data -> data list (** [find_all x] returns a list of all the instances of [x] found in t. - @since Boron-20100401 ) + @since Boron-20100401 ) val mem: data -> bool (** [mem x] returns [true] if there is at least one instance of [x] in the - table, [false] otherwise. - @since Boron-20100401 ) + table, [false] otherwise. + @since Boron-20100401 ) val remove: data -> unit (** [remove x] removes from the table one instance of [x]. Does nothing if - there is no instance of [x]. - @since Boron-20100401 ) + there is no instance of [x]. + @since Boron-20100401 ) end @@ -322,7 +328,7 @@ (** Hash function for datatype internally used by the built table. *) val initial_values: t list (** Pre-existing values stored in the built table and shared by all - existing projects. ) + existing projects. ) end) (Info: Info_with_size) : Weak_hashtbl with type data = Data.t @@ -338,8 +344,8 @@ module type Hashtbl = sig include S (** Hashtbl are a standard computation. - BUT that is INCORRECT to use projectified hashtables if keys have a - custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) ) + BUT that is INCORRECT to use projectified hashtables if keys have a + custom [rehash] function (see {!Project.DATATYPE_OUTPUT.rehash}) ) type key type data @@ -355,12 +361,12 @@ val fold: (key -> data -> 'a -> 'a) -> 'a -> 'a val memo: ?change:(data -> data) -> (key -> data) -> key -> data (** Memoization. Compute on need the data associated to a given key using - the given function. - If the data is already computed, it is possible to change with - [change]. ) + the given function. + If the data is already computed, it is possible to change with + [change]. ) val find: key -> data (** Return the current binding of the given key. - @raise Not_found if the key is not in the table. ) + @raise Not_found if the key is not in the table. ) val find_all: key -> data list (** Return the list of all data associated with the given key. *) val mem: key -> bool @@ -368,10 +374,11 @@ end module Hashtbl - (H: Datatype.Hashtbl) - (Data: Datatype.S) + (H: Datatype.Hashtbl (** hashtable implementation *)) + (Data: Datatype.S (** datatype for values stored in the table )) (Info: Info_with_size) : Hashtbl with type key = H.key and type data = Data.t + and module Datatype = H.Make(Data) ( ************************************************************************* *) (** {3 References on a set} *) @@ -379,7 +386,7 @@ (** Output signature of builders of references on a set. *) module type Set_ref = sig - include S + include Ref type elt val add: elt -> unit val is_empty: unit -> bool @@ -420,7 +427,7 @@ | Backward (** All states in the proxy depend on it. *) | Forward (** The proxy depends on all states inside. *) | Both (** States in the proxy and the proxy itself are mutually - dependent. ) + dependent. ) val create: string -> kind -> State.standard_kind -> State.t list -> t (** [create s k sk l] creates a new proxy with the given name, kinds and @@ -441,19 +448,27 @@ val apply_once: string -> State.t list -> (unit -> unit) -> (unit -> unit) * State.t (** [apply_once name dep f] returns a closure applying [f] only once and the - state internally used. [name] and [dep] are respectively the name and - the dependencies of the local state created by this function. Should - be used partially applied. If [f] raises an exception, then it is - considered as not applied. ) + state internally used. [name] and [dep] are respectively the name and + the dependencies of the local state created by this function. Should + be used partially applied. If [f] raises an exception, then it is + considered as not applied. ) -( Creates a projectified counter which is marshalling compliant. +( Creates a shared counter which is marshalling compliant. @since Carbon-20101201 *) -module Counter(Info : sig val name : string end) : -sig - val next : unit -> int +module SharedCounter(Info : sig val name : string end) : sig + val next : unit -> int (** Increments the counter and returns a fresh value *) end +(** Creates a shared counter which is marshalling compliant. + @since Nitrogen-20111001 *) +module Counter(Info : sig val name : string end) : sig + val next : unit -> int + (** Increments the counter and returns a fresh value ) + + val self: State.t +end + ( Local Variables: compile-command: "make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_dependency_graph.ml frama-c-20111001+nitrogen+dfsg/src/project/state_dependency_graph.ml --- frama-c-20110201+carbon+dfsg/src/project/state_dependency_graph.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_dependency_graph.ml 2011-10-10 08:38:25.000000000 +0000 @@ -23,7 +23,7 @@ module type G = sig module V: Graph.Sig.VERTEX with type t = State.t and type label = State.t module E: Graph.Sig.EDGE with type vertex = State.t - and type t = State.t * State.t + and type t = State.t * State.t type t val iter_vertex: (V.t -> unit) -> t -> unit val fold_vertex: (V.t -> 'a -> 'a) -> t -> 'a -> 'a @@ -67,7 +67,7 @@ type graphs = { internal_graph: Dependency_graph.t; - mutable external_graph: Dependency_graph.t } + mutable external_graph: Dependency_graph.t } (* invariant: for each edge in external_graph, @@ -230,21 +230,21 @@ let iter_succ f _g v = on_vertex (fun g v -> - Single_graph.iter_succ f g v; - try Single_graph.external_iter_succ f g v - with Invalid_argument _ -> ()) + Single_graph.iter_succ f g v; + try Single_graph.external_iter_succ f g v + with Invalid_argument _ -> ()) v let fold_succ f _g v acc = on_vertex (fun g v acc -> - let acc = Single_graph.fold_succ f g v acc in - try - Single_graph.external_fold_succ - (fun v acc -> try f v acc with Invalid_argument _ -> assert false) - g v acc - with Invalid_argument _ -> - acc) + let acc = Single_graph.fold_succ f g v acc in + try + Single_graph.external_fold_succ + (fun v acc -> try f v acc with Invalid_argument _ -> assert false) + g v acc + with Invalid_argument _ -> + acc) v acc @@ -252,8 +252,8 @@ let g = !g in List.fold_left (fun acc g -> - try Single_graph.external_fold_pred f g v acc - with Invalid_argument _ -> acc) + try Single_graph.external_fold_pred f g v acc + with Invalid_argument _ -> acc) (on_vertex (Single_graph.fold_pred f) v acc) g @@ -261,17 +261,17 @@ let g = !g in List.fold_left (fun n g -> - try Single_graph.external_in_degree g v + n - with Invalid_argument _ -> n) + try Single_graph.external_in_degree g v + n + with Invalid_argument _ -> n) (on_vertex Single_graph.in_degree v) g let out_degree _g v = on_vertex (fun g v -> - let n = Single_graph.out_degree g v in - try Single_graph.external_out_degree g v + n - with Invalid_argument _ -> n) + let n = Single_graph.out_degree g v in + try Single_graph.external_out_degree g v + n + with Invalid_argument _ -> n) v let nb_vertex g = fold_vertex (fun _ -> succ) g 0 @@ -312,9 +312,9 @@ let get_graph s = try (Vertices.find s).Single_graph.id with Not_found -> -(* Format.printf "state %S (%S) not found@." - (State.get_unique_name s) (State.get_name s);) - assert false +( Format.printf "state %S (%S) not found@." + (State.get_unique_name s) (State.get_name s);*) + assert false let color n = `Color (Extlib.number_to_color n) let vertex_name s = "\"" ^ State.get_unique_name s ^ "\"" @@ -332,8 +332,8 @@ let get_subgraph s = let n = get_graph s in Some - { DotAttributes.sg_name = string_of_int n; - sg_attributes = [ color n ] } + { DotAttributes.sg_name = string_of_int n; + sg_attributes = [ color n ] } end @@ -386,25 +386,20 @@ type local_search = Begin | Static | Dynamic of Single_graph.t let add_state_like_the_others states s = - if states = [] then - Project_skeleton.Output.fatal - "State_dependency_graph.add_state_like_others: \ -non empty list of states required"; let rec search go = function | [] -> go | s' :: l -> let g' = Vertices.find s' in let go = match go with - | Begin | Static -> - if Single_graph.equal g' Static.graph then Static else Dynamic g' - | Dynamic _ -> go + | Begin | Static -> + if Single_graph.equal g' Static.graph then Static else Dynamic g' + | Dynamic _ -> go in search go l in match search Begin states with - | Begin -> assert false - | Static -> Static.add_state s [] + | Begin | Static -> Static.add_state s [] | Dynamic g -> Single_graph.add_vertex g s; Vertices.add s g false @@ -448,10 +443,10 @@ module Datatype = Datatype.Make (struct - include Datatype.Undefined - type t = Local.t - let name = "State_dependency_graph.Make_dynamic(" ^ T.name ^ ").t" - let reprs = [ graph.graphs ] + include Datatype.Undefined + type t = Local.t + let name = "State_dependency_graph.Make_dynamic(" ^ T.name ^ ").t" + let reprs = [ graph.graphs ] end) let () = Type.set_ml_name Datatype.ty None @@ -483,7 +478,7 @@ | `Tuning | `Correctness | `Proxy (`Internal | `Correctness) -> - G.iter_pred (fun s' -> H.replace h s' ()) g s + G.iter_pred (fun s' -> H.replace h s' ()) g s in D.iter ~post g; H.fold (fun v () g -> G.remove_vertex g v) to_be_removed g diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_dependency_graph.mli frama-c-20111001+nitrogen+dfsg/src/project/state_dependency_graph.mli --- frama-c-20110201+carbon+dfsg/src/project/state_dependency_graph.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_dependency_graph.mli 2011-10-10 08:38:25.000000000 +0000 @@ -33,7 +33,7 @@ (** @since Carbon-20101201 ) module E: Graph.Sig.EDGE with type vertex = State.t - and type t = State.t State.t + and type t = State.t * State.t type t (** @since Carbon-20101201 *) @@ -154,8 +154,8 @@ val add_state_like_the_others: State.t list -> State.t -> unit (** [add_state_like_others l s] adds [s] to the same graph that each state of - [l]. If states of [l] belong to different graphs, then adds [s] to the best - graph as possible. + [l]. If states of [l] belong to different graphs or if [l] is empty, then + adds [s] to the best graph as possible. @since Carbon-20101201 ) module Vertices: State.Local diff -Nru frama-c-20110201+carbon+dfsg/src/project/state.ml frama-c-20111001+nitrogen+dfsg/src/project/state.ml --- frama-c-20110201+carbon+dfsg/src/project/state.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state.ml 2011-10-10 08:38:25.000000000 +0000 @@ -60,6 +60,7 @@ copy: t -> t -> unit; commit: t -> unit; update: t -> unit; + on_update: (unit -> unit) -> unit; clean: unit -> unit; serialize: t -> state_on_disk; unserialize: t -> state_on_disk -> unit } @@ -96,6 +97,7 @@ copy = never_called; commit = never_called; update = never_called; + on_update = never_called; serialize = never_called; unserialize = never_called; clean = never_called } @@ -124,16 +126,16 @@ let structural_descr = Structural_descr.Unknown let reprs = [ dummy ] let compare x y = - if x == y then 0 else String.compare x.unique_name y.unique_name + if x == y then 0 else String.compare x.unique_name y.unique_name let equal = (==) let hash x = Hashtbl.hash x.unique_name let copy = Datatype.undefined let rehash = Datatype.undefined let internal_pretty_code p_caller fmt s = - let pp fmt = - Format.fprintf fmt "@[<hv 2>State.get@;%S@]" s.unique_name - in - Type.par p_caller Type.Call fmt pp + let pp fmt = + Format.fprintf fmt "@[<hv 2>State.get@;%S@]" s.unique_name + in + Type.par p_caller Type.Call fmt pp let pretty fmt s = Format.fprintf fmt "state %S" s.unique_name let varname = Datatype.undefined let mem_project = Datatype.never_any_project @@ -152,6 +154,7 @@ let get_descr s = s.private_ops.descr let set_name s n = s.name <- n +let add_hook_on_update s f = s.private_ops.on_update f ( ************************************************************************** *) (** {2 States are comparable values} ) @@ -214,6 +217,13 @@ Caml_hashtbl.add !states uname s; if is_static then Caml_hashtbl.add statics uname s +let unique_name_from_name = + let module M = + Project_skeleton.Make_setter + (struct let mem s = Caml_hashtbl.mem !states s end) + in + M.make_unique_name + ( ************************************************************************** *) (** {3 Cluster} ) ( ************************************************************************** ) @@ -223,7 +233,7 @@ let edit_cluster c states = let set_cluster s = if s.cluster <> None then - Output.fatal "state %S already in a cluster." s.unique_name; + Output.fatal "state %S already in a cluster." s.unique_name; s.cluster <- Some c in List.iter set_cluster states @@ -231,9 +241,9 @@ let create_and_return name states = if States.exists - (fun s -> match s.cluster with - | None -> false - | Some c -> c.c_name = name) + (fun s -> match s.cluster with + | None -> false + | Some c -> c.c_name = name) then Output.fatal "cluster %S already exists." name; let c = { c_name = name; states = states } in @@ -252,9 +262,9 @@ let extend name states = try States.iter - (fun _ s -> match s.cluster with - | None -> () - | Some c -> raise (Found c)); + (fun _ s -> match s.cluster with + | None -> () + | Some c -> raise (Found c)); Output.fatal "no existing cluster %S." name; with Found c -> unsafe_extend c states @@ -278,11 +288,11 @@ | Some n -> let l = [ state ] in try - let c = Datatype.String.Hashtbl.find h n in - unsafe_extend c l + let c = Datatype.String.Hashtbl.find h n in + unsafe_extend c l with Not_found -> - let c = create_and_return n l in - Datatype.String.Hashtbl.add h n c), + let c = create_and_return n l in + Datatype.String.Hashtbl.add h n c), (fun () -> Datatype.String.Hashtbl.clear h) end @@ -311,7 +321,7 @@ let create ~descr ~create ~remove ~clear ~clear_some_projects ~copy - ~commit ~update ~clean ~serialize ~unserialize + ~commit ~update ~on_update ~clean ~serialize ~unserialize ~unique_name ~name kind = let ops = { descr = descr; @@ -322,6 +332,7 @@ copy = copy; commit = commit; update = update; + on_update = on_update; clean = clean; serialize = serialize; unserialize = unserialize } diff -Nru frama-c-20110201+carbon+dfsg/src/project/state.mli frama-c-20111001+nitrogen+dfsg/src/project/state.mli --- frama-c-20110201+carbon+dfsg/src/project/state.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state.mli 2011-10-10 08:38:25.000000000 +0000 @@ -20,7 +20,7 @@ ( *) (**********************************************************************) -( A state is a meta-representation of a project-compliant mutable value. +( A state is a project-compliant mutable value. @since Carbon-20101201 *) open Project_skeleton @@ -33,7 +33,7 @@ [ | `Correctness (** The state has an impact on the correctness of a result. *) | `Internal (** The state is for internal purpose only: - it is hidden to the external user. ) + it is hidden to the external user. ) ] ( Type of state kinds. @@ -42,11 +42,11 @@ [ | standard_kind | `Tuning ( The state has an impact on a result, - but it does not change its correctness. - For instance, it just improves the preciseness. ) + but it does not change its correctness. + For instance, it just improves the preciseness. ) | `Irrelevant (** The state has no impact on any result. - If any analyser is run, then its result is not modified by - setting this state. ) + If any analyser is run, then its result is not modified by + setting this state. ) ] type kind = @@ -68,22 +68,22 @@ val create: unit -> t (** How to create a new fresh state which must be equal to the initial - state: that is, if you never change the state, [create ()] and [get - ()] must be equal (see invariant 1 below). ) + state: that is, if you never change the state, [create ()] and [get + ()] must be equal (see invariant 1 below). ) val clear: t -> unit (** How to clear a state. After clearing, the state should be - observationaly the same that after its creation (see invariant 2 - below). - @plugin development guide ) + observationaly the same that after its creation (see invariant 2 + below). + @plugin development guide ) val get: unit -> t (** How to access to the current state. Be aware of invariants 3 and 4 - below. ) + below. ) val set: t -> unit (** How to change the current state. Be aware of invariants 3 and 4 - below. ) + below. ) ( The four following invariants must hold. {ol @@ -119,6 +119,10 @@ ( Unique name of a state. @since Carbon-20101201 *) +val unique_name_from_name: string -> string +(** @return a fresh unique state name from the given name. + @since Nitrogen-20111001 *) + val kind: t -> kind (** Kind of a state. @since Carbon-20101201 *) @@ -142,6 +146,11 @@ val get_descr: t -> Structural_descr.pack (** @since Carbon-20101201 *) +val add_hook_on_update: t -> (unit -> unit) -> unit +(** Add an hook which is applied each time the project library changes the local + value of the state. + @since Nitrogen-20111001 ) + ( ************************************************************************** *) (** {2 Clusters} ) ( ************************************************************************** *) @@ -168,19 +177,19 @@ val name: t -> string option (** [cluster_name s] returns the name of cluster of [s], if any. - @since Carbon-20101201 ) - + @since Carbon-20101201 ) + (** {2 Internal Stuff} *) val unmarshal: string option -> t -> unit (** How to unmarshal a cluster stored in a state, previously marshaled with - its name. - @since Carbon-20101201 ) + its name. + @since Carbon-20101201 ) val after_load: unit -> unit (** Must be called after each project loading. - Exported for breaking mutual dependencies with [Project]. - @since Carbon-20101201 ) + Exported for breaking mutual dependencies with [Project]. + @since Carbon-20101201 ) end @@ -207,6 +216,7 @@ copy: project -> project -> unit; commit: project -> unit; update: project -> unit; + on_update: (unit -> unit) -> unit; clean: unit -> unit; serialize: project -> state_on_disk; unserialize: project -> state_on_disk -> unit } @@ -251,6 +261,7 @@ copy:(project -> project -> unit) -> commit:(project -> unit) -> update:(project -> unit) -> + on_update:((unit -> unit) -> unit) -> clean:(unit -> unit) -> serialize:(project -> state_on_disk) -> unserialize:(project -> state_on_disk -> unit) -> @@ -258,7 +269,8 @@ name:string -> kind -> t -(** @since Carbon-20101201 *) +(** @since Carbon-20101201 + @modify Nitrogen-20111001 add the [on_update] argument ) ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_selection.ml frama-c-20111001+nitrogen+dfsg/src/project/state_selection.ml --- frama-c-20110201+carbon+dfsg/src/project/state_selection.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_selection.ml 2011-10-10 08:38:25.000000000 +0000 @@ -33,6 +33,9 @@ let is_empty s = s = Subset Selection.empty let is_full s = s = Full +let mem sel s = match sel with + | Full -> true + | Subset sel -> Selection.mem_vertex sel s include Datatype.Make (struct @@ -46,20 +49,20 @@ match Selection.fold_vertex (fun s acc -> s :: acc) sel [] with | [] -> Format.fprintf fmt "@[State_selection.empty@]" | [ s ] -> - let pp fmt = - Format.fprintf fmt "@[<hv 2>State_selection.singleton@;%a@]" - (State.internal_pretty_code Type.Call) - s - in - Type.par p_caller Type.Call fmt pp + let pp fmt = + Format.fprintf fmt "@[<hv 2>State_selection.singleton@;%a@]" + (State.internal_pretty_code Type.Call) + s + in + Type.par p_caller Type.Call fmt pp | l -> - let module D = Datatype.List(State) in - let pp fmt = - Format.fprintf fmt "@[<hv 2>State_selection.of_list@;%a@]" - (D.internal_pretty_code Type.Call) - l - in - Type.par p_caller Type.Call fmt pp + let module D = Datatype.List(State) in + let pp fmt = + Format.fprintf fmt "@[<hv 2>State_selection.of_list@;%a@]" + (D.internal_pretty_code Type.Call) + l + in + Type.par p_caller Type.Call fmt pp end) module type S = sig @@ -85,11 +88,11 @@ let transitive_closure next_vertices s = let rec visit acc v = next_vertices - (fun v' acc -> - let e = v, v' in - if Selection.mem_edge_e acc e then acc - else visit (Selection.add_edge_e acc e) v') - G.graph v acc + (fun v' acc -> + let e = v, v' in + if Selection.mem_edge_e acc e then acc + else visit (Selection.add_edge_e acc e) v') + G.graph v acc in (* add [s] in the selection even if it has no ingoing/outgoing edges *) visit (Selection.add_vertex Selection.empty s) s @@ -115,19 +118,19 @@ (fun v acc -> if Selection.mem_vertex sel2 v then acc else Selection.add_vertex acc v) - G.graph + G.graph Selection.empty in - G.G.fold_edges - (fun v1 v2 acc -> - if Selection.mem_vertex sel2 v1 || Selection.mem_vertex sel2 v2 - then acc - else Selection.add_edge acc v1 v2) - G.graph - selection + G.G.fold_edges + (fun v1 v2 acc -> + if Selection.mem_vertex sel2 v1 || Selection.mem_vertex sel2 v2 + then acc + else Selection.add_edge acc v1 v2) + G.graph + selection | Subset sel1, Subset sel2 -> - Selection.fold_vertex - (fun v acc -> Selection.remove_vertex acc v) sel2 sel1) + Selection.fold_vertex + (fun v acc -> Selection.remove_vertex acc v) sel2 sel1) let union = let module O = Graph.Oper.P(Selection) in @@ -170,14 +173,14 @@ Format.fprintf fmt "contents of the selection:@\n"; let mem s = State_dependency_graph.Static.G.mem_vertex - State_dependency_graph.Static.graph - s + State_dependency_graph.Static.graph + s in iter_in_order (fun s -> - Format.fprintf fmt "\t state %S%s@\n" - (State.get_unique_name s) - (if mem s then "" else "(\"" ^ State.get_name s ^ "\")")) + Format.fprintf fmt "\t state %S%s@\n" + (State.get_unique_name s) + (if mem s then "" else "(\"" ^ State.get_name s ^ "\")")) sel; Format.pp_print_flush fmt () @@ -185,7 +188,7 @@ | Full -> assert false | Subset sel -> let module R = - State_dependency_graph.Remove_useless_states(Selection)(State) + State_dependency_graph.Remove_useless_states(Selection)(State) in Subset (R.get sel) @@ -204,9 +207,9 @@ match s with | Full -> DG.dump filename | Subset s -> - let cout = open_out filename in - DS.output_graph cout s; - close_out cout + let cout = open_out filename in + DS.output_graph cout s; + close_out cout end include Dot(State_dependency_graph.Dynamic.Attributes) diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_selection.mli frama-c-20111001+nitrogen+dfsg/src/project/state_selection.mli --- frama-c-20110201+carbon+dfsg/src/project/state_selection.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_selection.mli 2011-10-10 08:38:25.000000000 +0000 @@ -68,6 +68,8 @@ (** @return [true] iff the selection contains all the states. @since Carbon-20101201 ) +val mem: t -> State.t -> bool + ( ************************************************************************** *) (** {2 Specific selections} ) ( ************************************************************************** ) diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_topological.ml frama-c-20111001+nitrogen+dfsg/src/project/state_topological.ml --- frama-c-20110201+carbon+dfsg/src/project/state_topological.ml 2011-02-07 13:53:52.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_topological.ml 2011-10-10 08:38:25.000000000 +0000 @@ -46,38 +46,38 @@ let rec walk acc = if Queue.is_empty todo then ( let's find any node of minimal degree ) - let min = - H.fold - (fun v d acc -> - match acc with - | None -> Some (v, d) - | Some(_, min) -> if d < min then Some (v, d) else acc) - degree - None - in - match min with - | None -> acc - | Some(v, _) -> push v; walk acc + let min = + H.fold + (fun v d acc -> + match acc with + | None -> Some (v, d) + | Some(_, min) -> if d < min then Some (v, d) else acc) + degree + None + in + match min with + | None -> acc + | Some(v, _) -> push v; walk acc else - let v = Queue.pop todo in - let acc = f v acc in - G.iter_succ - (fun x-> + let v = Queue.pop todo in + let acc = f v acc in + G.iter_succ + (fun x-> try let d = H.find degree x in - if d = 1 then push x else H.replace degree x (d-1) + if d = 1 then push x else H.replace degree x (d-1) with Not_found -> - ( [x] already visited ) - ()) - g v; - do_cluster v; - walk acc + ( [x] already visited ) + ()) + g v; + do_cluster v; + walk acc in G.iter_vertex (fun v -> - let d = G.in_degree g v in - if d = 0 then Queue.push v todo - else H.add degree v d) + let d = G.in_degree g v in + if d = 0 then Queue.push v todo + else H.add degree v d) g; let acc = walk acc in H.fold (fun v () acc -> f v acc) in_cluster acc diff -Nru frama-c-20110201+carbon+dfsg/src/project/state_topological.mli frama-c-20111001+nitrogen+dfsg/src/project/state_topological.mli --- frama-c-20110201+carbon+dfsg/src/project/state_topological.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/project/state_topological.mli 2011-10-10 08:38:25.000000000 +0000 @@ -20,7 +20,7 @@ ( *) (**********************************************************************) -( Topological order. +( Topological ordering over states. This functor provides functions which allow iterating over a state graph in topological order. diff -Nru frama-c-20110201+carbon+dfsg/src/report/configure frama-c-20111001+nitrogen+dfsg/src/report/configure --- frama-c-20110201+carbon+dfsg/src/report/configure 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/configure 2011-10-10 08:56:39.000000000 +0000 @@ -0,0 +1,3271 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.65. +# +# +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, +# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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. +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 + +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" + 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 : + # 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. + BASH_ENV=/dev/null + ENV=/dev/null + (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} +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_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 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=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 + fi + $as_echo "$as_me: error: $1" >&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; } + + # 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 -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +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 + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]):;;)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# 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 </dev/null +exec 6>&1 + +# Name of the host. +# hostname on some systems (SVR3.2, 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="Makefile.in" +ac_subst_vars='LTLIBOBJS +LIBOBJS +DYNAMIC_REPORT +ENABLE_REPORT +ENABLE_GUI +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 +enable_report +with_report_static +' + 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=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 + $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 + 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 + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-report support for report plug-in (default: yes) + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-report-static link report statically (default: no) + +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.65 + +Copyright (C) 2009 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.65. 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 + + cat <<\_ASBOX +## ---------------- ## +## Cache variables. ## +## ---------------- ## +_ASBOX + 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 + + cat <<\_ASBOX +## ----------------- ## +## Output variables. ## +## ----------------- ## +_ASBOX + 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 + cat <<\_ASBOX +## ------------------- ## +## File substitutions. ## +## ------------------- ## +_ASBOX + 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 + cat <<\_ASBOX +## ----------- ## +## confdefs.h. ## +## ----------- ## +_ASBOX + 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 + ac_site_file1=$CONFIG_SITE +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" + 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 + + + KNOWN_PLUGINS=$(frama-c -help | \ + sed -e '0,/^\\\\\/ d' \ + -e 's/$[^ ][^ ]\( [^ ][^ ]$\) ./\1/' \ + -e '/^ /d' -e '/^$/d' | \ + tr "a-z- " "A-Z__") + for plugin in ${KNOWN_PLUGINS}; do + export $(echo ENABLE_$plugin)=yes + done + # Extract the first word of "frama-c-gui", so it can be a program name with args. +set dummy frama-c-gui; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_prog_ENABLE_GUI+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ENABLE_GUI"; then + ac_cv_prog_ENABLE_GUI="$ENABLE_GUI" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_ENABLE_GUI="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_ENABLE_GUI" && ac_cv_prog_ENABLE_GUI="no" +fi +fi +ENABLE_GUI=$ac_cv_prog_ENABLE_GUI +if test -n "$ENABLE_GUI"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ENABLE_GUI" >&5 +$as_echo "$ENABLE_GUI" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + + + +upper() { + echo "$1" | tr "a-z-" "A-Z_" +} + +lower() { + echo "$1" | tr "A-Z" "a-z" +} + + + +new_section() { + banner=`echo " $1 " | sed -e 's/.//g'` + title=`echo "* $1 " | tr "a-z" "A-Z"` + { $as_echo "$as_me:${as_lineno-$LINENO}: $banner" >&5 +$as_echo "$as_me: $banner" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: $title" >&5 +$as_echo "$as_me: $title" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: $banner" >&5 +$as_echo "$as_me: $banner" >&6;} +} + + + +# sadly, there's no way to define a new diversion beside the internal ones. +# hoping for the best here... + + + + +# to distinguish internal plugins, known by the main configure, from +# purely external plugins living in src/ and compiled together with the main +# frama-c + + + + # end of check_plugin + +# 1st param: uppercase name of the library +# 2nd param: file which must exist. This parameter can be a list of files. +# In this case, they will be tried in turn until one of them exists. The +# name of the file found will be put in the variable SELECTED_$1 +# 3d param: warning to display if problem +# 4th param: yes iff checking the library must always to be done +# (even if there is no plug-in using it) + + +# 1st param: uppercase name of the program +# 2nd param: program which must exist. See comment on configure_library() +# on how to deal with multiple choices for a given program. +# 3d param: warning to display if problem +# 4th param: yes iff checking the tool must always to be done +# (even if there is no plug-in using it) + + +EXTERNAL_PLUGINS= + + + + + + + + +# Implementation of an ordering $1 < $2: "" < yes < partial < no +lt_mark () { + first=`echo "$1" | sed -e 's/ .//' ` + second=`echo "$2" | sed -e 's/ .//' ` + case $first in + "") echo "true";; + "yes") + case $second in + "yes") echo "";; + "partial" | "no") echo "true";; + esac;; + "partial") + case $second in + "yes" | "partial") echo "";; + "no") echo "true";; + esac;; + "no") echo "";; + esac +} + +# Check and propagate marks to requires and users. +# $1: parent plugin +# $2: mark to propagate to requires +# $3: mark to propagate to users +check_and_propagate () { + # for each requiers + r=REQUIRE_$1 + eval require="\$$r" + for p in $require; do + up=`upper "$p"` + m=MARK_"$up" + eval mark="\$$m" + if test -z "$mark"; then + m=ENABLE_"$up" + eval mark="\$$m" + fi + if test `lt_mark "$mark" "$2" `; then + # update marks + eval MARK_$up=\"$2\"; + TODOLIST=$TODOLIST" "$p + # display a warning or an error if required + short_mark=`echo $2 | sed -e 's/ .//'` + lp=`lower $p` + reason=`echo $2 | sed -e 's/no ($.$)/\1/' ` + if test "$short_mark" = "no"; then + fp=FORCE_"$up" + if eval test "\$$fp" = "yes"; then + as_fn_error "$lp requested but $reason." "$LINENO" 5 + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $lp disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $lp disabled because $reason." >&2;} + fi + else + if test "$short_mark" = "partial"; then + reason=`echo $2 | sed -e 's/partial ($.$)/\1/' ` + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $lp only partially enable because $reason." >&5 +$as_echo "$as_me: WARNING: $lp only partially enable because $reason." >&2;} + fi + fi + eval INFO_$up=\", $reason\" + fi + done + # for each users + u=USE_$1 + eval use="\$$u" + for p in $use; do + up=`upper "$p"` + m=MARK_$up + eval mark="\$$m" + if test -z "$mark"; then + m=ENABLE_"$up" + eval mark="\$$m" + fi + if test `lt_mark "$mark" "$3" `; then + # update marks + eval MARK_$up=\"$3\"; + TODOLIST=$TODOLIST" "$p + # display a warning if required + lp=`lower $p` + reason=`echo $3 | sed -e 's/partial ($.$)/\1/' ` + if test "$reason" != "$3"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $lp only partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $lp only partially enabled because $reason." >&2;} + fi + eval INFO_$up=\", $reason\" + fi + done +} + +# checks direct dependencies of a plugin. Useful for dynamic plugins which +# have a dependency toward already installed (or not) plug-ins, since the old +# plugins are not in the TODO list from the beginning (and need not their +# mutual dependencies be rechecked anyway +check_required_used () { + ep=ENABLE_$1 + eval enabled=\$$ep + + if test "$enabled" != "no"; then + + r=REQUIRED_$1 + u=USED_$1 + m=MARK_$1 + eval required=\$$r + eval used=\$$u + eval $m=yes + + reason= + + for p in $required; do + up=`upper $p` + ec=ENABLE_$up + eval enabled=\$$ec + case `echo "$enabled" | sed -e 's/ .//'` in + "") reason="$p unknown";; + "yes" | "partial");; + "no") reason="$p not enabled";; + esac + done + if test -n "$reason"; then + eval $m=\"no\ $$reason$\" + p_name=`lower $1` + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p_name disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p_name disabled because $reason." >&2;} + eval INFO_$1=\", $reason\" + else + for p in $used; do + up=`upper $p` + ec=ENABLE_$up + eval enabled=\$$ec + case `echo "$enabled" | sed -e 's/ .//'` in + "") reason="$p unknown";; + "yes" | "partial");; + "no") reason="$p not enabled";; + esac + done + if test -n "$reason"; then + eval $m=\"partial\ $$reason$\" + p_name=`lower $1` + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p_name partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p_name partially enabled because $reason." >&2;} + eval INFO_$1=\", $reason\" + fi + fi + + else # $enabled = "no" + eval $m=\"no\" + fi +} + +# Recursively check the plug-in dependencies using the plug-in dependency graph +compute_dependency () { + plugin=`echo $TODOLIST | sed -e 's/ .//' ` + TODOLIST=`echo $TODOLIST | sed -e 's/[^ ] $.$/\1/' ` + + lplugin=`lower "$plugin"` + uplugin=`upper "$plugin"` + # new mark to consider + m=MARK_$uplugin + eval mark="\$$m" + # old mark to consider + r=REMEMBER_$uplugin + eval remember="\$$r" + # the exact mark (final result), + # also the old mark if plugin already visited + e=ENABLE_$uplugin + eval enable="\$$e" + #first visit. Performs additional checks over requirements. + if test -z "$mark"; then + check_required_used "$uplugin"; + eval mark=\$$m + fi + +# echo "plug-in $lplugin (mark=$mark, remember=$remember, enable=$enable)" + if test `lt_mark "$remember" "$mark"`; then + # visit the current plugin: + # mark <- max(mark, enable) + case `echo "$mark" | sed -e 's/ .//' ` in + "") echo "problem?"; exit 3;; + "yes") + if test -n "$enable"; then mark="$enable"; else mark="yes"; fi;; + "partial") if test "$enable" = "no"; then mark="no"; fi;; + "no") ;; + esac + # update plug-in attributes with the new mark +# echo "update attributes with $mark" + eval $m=\"$mark\" + eval $e=\"`echo "$mark" | sed -e 's/ .//' `\" + enable="$mark" + eval $r=\"$mark\" + # compute and propagate a new mark to requires and users + case `echo "$enable" | sed -e 's/ .//' ` in + "") echo "problem?"; exit 3;; + "yes") check_and_propagate $uplugin "yes" "yes";; + "partial") +# if a plug-in is partial, does not consider its dependencies as partial +# so the second argument is "yes" and not "partial" + check_and_propagate \ + "$uplugin" \ + "yes" \ + "yes";; + "no") + check_and_propagate \ + "$uplugin" \ + "no ($lplugin not enabled)" \ + "partial ($lplugin not enabled)";; + esac + fi + # recursively consider the next plugins + if test -n "$TODOLIST"; then + compute_dependency; + fi +} + + + + + + + + + + + + + + + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Makefile.in" >&5 +$as_echo_n "checking for Makefile.in... " >&6; } +if test "${ac_cv_file_Makefile_in+set}" = set; 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 "Makefile.in"; then + ac_cv_file_Makefile_in=yes +else + ac_cv_file_Makefile_in=no +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_Makefile_in" >&5 +$as_echo "$ac_cv_file_Makefile_in" >&6; } +if test "x$ac_cv_file_Makefile_in" = x""yes; then : + default=yes;plugin_present=yes +else + plugin_present=no;default=no +fi + + +FORCE=no + +# Check whether --enable-report was given. +if test "${enable_report+set}" = set; then : + enableval=$enable_report; ENABLE=$enableval;FORCE=$enableval +else + ENABLE=$default + +fi + + +if test "$ONLY_KERNEL" = "yes" -a "$FORCE" = "no"; then + ENABLE=no +fi + + + +# Test to change for static plugin, dynamic option +#default_dyn=no +#define([PLUGIN_HELP_DYN], +# AC_HELP_STRING([--enable-PLUGIN_NAME-dynamic], +# [PLUGIN_MSG (default: static)]) +#define([PLUGIN_NAME_DYN],[PLUGIN_NAME]-dynamic) +#AC_ARG_ENABLE( +# [PLUGIN_NAME_DYN], +# PLUGIN_HELP_DYN, +# ENABLE=$enableval; +# FORCE=$enableval +# ENABLE=$default_dyn +#) +#eval ENABLE_DYNAMIC_$up=\$ENABLE + +if test "$plugin_present" = "no" -a "$FORCE" = "yes"; then + as_fn_error "report is not available" "$LINENO" 5 +fi + +FORCE_REPORT=$FORCE +PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_REPORT + +ENABLE_REPORT=$ENABLE +NAME_REPORT=report +if test "$default" = "no" -a "$FORCE" = "no"; then + INFO_REPORT=" (not available by default)" +fi + +# Dynamic plug-ins configuration + + +# Check whether --with-report-static was given. +if test "${with_report_static+set}" = set; then : + withval=$with_report_static; is_static=$withval +else + is_static=$IS_ALL_STATIC +fi + + + # is_static = "yes" iff the user forces the plug-in to be static + # is_static = "no" iff the user forces the plug-in to be dynamic + # is_static = "" in others cases (no special instruction) + STATIC_REPORT=$is_static + if test "$is_static" != "yes"; then + USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} report" + DYNAMIC_REPORT=yes + else + DYNAMIC_REPORT=no + fi + + + +echo "report... $ENABLE" +# kept defined for write_plugin_config. A bit ugly, but not more than +# usual autoconf stuff. +# m4_undefine([PLUGIN_NAME]) + + + + + + + + +####################### +# Generating Makefile # +####################### + + + + + ac_config_files="$ac_config_files ./Makefile" + + + + +# Compute INFO_ and exported ENABLE_* from previously computed ENABLE_* + for fp in ${PLUGINS_FORCE_LIST}; do + if test "$fp" != "FORCE_GTKSOURCEVIEW"; then + plugin=`echo $fp | sed -e "s/FORCE_$.$/\1/" ` + ep=ENABLE_$plugin + eval v=\$$ep + eval ep_v=`echo $v | sed -e 's/ .//' ` + eval ENABLE_$plugin=$ep_v + reason=`echo $v | sed -e 's/[a-z]$ .$/\1/' ` + n=NAME_$plugin + eval name=\$$n + info= + if test "$reason" != "$ep_v"; then + info=$reason + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: $name: $ep_v$info" >&5 +$as_echo "$as_me: $name: $ep_v$info" >&6;} + fi + done + 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 + test "x$cache_file" != "x/dev/null" && + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + cat confcache >$cache_file + 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= +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. +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 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=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 + fi + $as_echo "$as_me: error: $1" >&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 -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +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 + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]):;;)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# 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.65. 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.65, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2009 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=$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"` ;; + 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") CONFIG_FILES="$CONFIG_FILES ./Makefile" ;; + + ) 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= + trap 'exit_status=$? + { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$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 -n "$tmp" && test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 + +# 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 2>/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 {' >"$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 >>"\$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 +' <conf$$subs.awk | sed ' +/^[^""]/{ + N + s/\n// +} +' >>$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$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 < "$tmp/subs1.awk" > "$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 $(srcdir), +# ${srcdir} and @srcdir@ 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[ ]=/{ +s/:\$(srcdir):/:/ +s/:\${srcdir}:/:/ +s/:@srcdir@:/:/ +s/^$[^=]=[ ]$:/\1/ +s/:$// +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="$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 "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 >"$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 "$tmp/subs.awk" >$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' "$tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]datarootdir[ ]:=/p' "$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 "$tmp/stdin" + case $ac_file in + -) cat "$tmp/out" && rm -f "$tmp/out";; + ) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; + esac \ + || as_fn_error "could not create $ac_file" "$LINENO" 5 + ;; + + + + esac + + + case $ac_file$ac_mode in + "./Makefile":F) chmod -w ./Makefile ;; + + 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 $? +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 + + + diff -Nru frama-c-20110201+carbon+dfsg/src/report/configure.ac frama-c-20111001+nitrogen+dfsg/src/report/configure.ac --- frama-c-20110201+carbon+dfsg/src/report/configure.ac 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/configure.ac 2011-10-10 08:38:25.000000000 +0000 @@ -0,0 +1,45 @@ +########################################################################## +# # +# This file is part of Frama-C. # +# # +# Copyright (C) 2007-2011 # +# CEA (Commissariat � l'�nergie atomique et aux �nergies # +# alternatives) # +# # +# you can redistribute it and/or modify it under the terms of the GNU # +# Lesser General Public License as published by the Free Software # +# Foundation, version 2.1. # +# # +# It 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 Lesser General Public License for more details. # +# # +# See the GNU Lesser General Public License version 2.1 # +# for more details (enclosed in the file licenses/LGPLv2.1). # +# # +########################################################################## + +######################################## +# E-ACSL as a standard Frama-C plug-in # +######################################## + +m4_define([plugin_file],Makefile.in) + +m4_define([FRAMAC_SHARE_ENV], + [m4_normalize(m4_esyscmd([echo $FRAMAC_SHARE]))]) + +m4_define([FRAMAC_SHARE], + [m4_ifval(FRAMAC_SHARE_ENV,[FRAMAC_SHARE_ENV], + [m4_esyscmd(frama-c -print-path)])]) + +m4_ifndef([FRAMAC_M4_MACROS], [m4_include(FRAMAC_SHARE/configure.ac)]) + +check_plugin(report,PLUGIN_RELATIVE_PATH(plugin_file), + [support for report plug-in],yes,yes) + +####################### +# Generating Makefile # +####################### + +write_plugin_config(Makefile) diff -Nru frama-c-20110201+carbon+dfsg/src/report/dump.ml frama-c-20111001+nitrogen+dfsg/src/report/dump.ml --- frama-c-20110201+carbon+dfsg/src/report/dump.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/dump.ml 2011-10-10 08:38:25.000000000 +0000 @@ -0,0 +1,187 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Dump Report on Output --- ) +( -------------------------------------------------------------------------- ) + +open Property_status +open Scan + +let bar = String.make 80 '-' +let dim = 9 ( Size for status [----] ) +let tab = String.make (dim+3) ' ' + +let pp_status fmt s = + let n = String.length s in + if n < dim then + let m = String.make dim ' ' in + let p = (dim - n) / 2 in + String.blit s 0 m p n ; + Format.fprintf fmt "[%s]" m + else Format.fprintf fmt "[%s]" s + +open Consolidation +module E = Emitter.Usable_emitter + +class dumper out = +object(self) + + val mutable st_unknown = 0 ; ( no status ) + val mutable st_partial = 0 ; ( locally valid but missing hyp ) + val mutable st_extern = 0 ; ( considered valid ) + val mutable st_complete = 0 ; ( valid and complete ) + val mutable st_bug = 0 ; ( invalid and complete ) + val mutable st_alarm = 0 ; ( invalid but missing hyp ) + val mutable st_dead = 0 ; ( under invalid hyp ) + val mutable st_inconsistent = 0 ; ( unsound ) + val mutable kf : Description.kf = `Always + + method started = () + + method global_section = + Format.fprintf out "%s@\n--- Global Properties@\n%s@\n@." bar bar + + method function_section thekf = + Format.fprintf out "@\n%s@\n--- Properties of Function '%s'@\n%s@\n@." + bar (Kernel_function.get_name thekf) bar ; + kf <- `Context thekf + + method category = function + | Never_tried | Unknown _ -> st_unknown <- succ st_unknown ; "-" + | Considered_valid -> st_extern <- succ st_extern ; "Extern" + | Valid _ -> st_complete <- succ st_complete ; "Valid" + | Invalid _ -> st_bug <- succ st_bug ; "Bug" + | Valid_under_hyp _ -> st_partial <- succ st_partial ; "Partial" + | Invalid_under_hyp _ -> st_alarm <- succ st_alarm ; "Alarm" + | Valid_but_dead _ | Invalid_but_dead _ | Unknown_but_dead _ -> + st_dead <- succ st_dead ; "Dead" + | Inconsistent _ -> st_inconsistent <- succ st_inconsistent ; "Unsound" + + method emitter e = Format.fprintf out "%s@[<hov 2>by %a.@]@\n" tab E.pretty e + + method emitters es = E.Set.iter self#emitter es + + method tried_emitters ps = + let es = E.Map.fold (fun e _ es -> e::es) ps [] in + match es with + | [] -> () + | e::es -> + Format.fprintf out "%s@[<hov 2>tried with %a" tab E.pretty e ; + List.iter (fun e -> Format.fprintf out ",@ %a" E.pretty e) es ; + Format.fprintf out ".@]@\n" + + method dead_reasons ps = + E.Map.iter + (fun e ps -> + Format.fprintf out "%s@[<hov 2>By %a because:@]@\n" tab E.pretty e ; + Property.Set.iter + (fun p -> Format.fprintf out "%s@[<hov 3> - %a@]@\n" tab + (Description.pp_localized ~kf ~ki:true) p) ps + ) (Scan.partial_pending ps) + + method partial_pending ps = + E.Map.iter + (fun e ps -> + Format.fprintf out "%s@[<hov 2>By %a, with pending:@]@\n" tab E.pretty e ; + Property.Set.iter + (fun p -> Format.fprintf out "%s@[<hov 3> - %a@]@\n" tab + (Description.pp_localized ~kf ~ki:true) p) ps + ) (Scan.partial_pending ps) + + method property ip st = + begin + Format.fprintf out "%a @[%a@]@\n" pp_status (self#category st) + (Description.pp_localized ~kf:`Never ~ki:true) ip ; + match st with + | Never_tried -> () + | Unknown emitters -> self#tried_emitters emitters + | Valid emitters -> self#emitters emitters + | Invalid emitters -> self#emitters emitters + | Invalid_but_dead pending -> + Format.fprintf out "%sLocally invalid, but unreachable.@\n" tab ; + self#dead_reasons pending + | Valid_but_dead pending -> + Format.fprintf out "%sLocally valid, but unreachable.@\n" tab ; + self#dead_reasons pending + | Unknown_but_dead pending -> + Format.fprintf out "%sLocally unknown, but unreachable.@\n"tab ; + self#dead_reasons pending + | Invalid_under_hyp pending | Valid_under_hyp pending -> + self#partial_pending pending + | Considered_valid -> + Format.fprintf out "%sUnverifiable but considered Valid.@\n" tab + | Inconsistent s -> + let p = ref 0 in + let n = String.length s in + while !p < n do + try + let k = String.index_from s !p '\n' in + Format.fprintf out "%s%s@\n" tab (String.sub s !p (k - !p)) ; + p := succ k ; + with Not_found -> + Format.fprintf out "%s%s@\n" tab (String.sub s !p (n - !p)) ; + p := n ; + done + + end + + method finished = + Format.fprintf out "@\n%s@\n--- Status Report Summary@\n%s@\n" bar bar ; + if st_complete > 0 then + Format.fprintf out " %4d Completely validated@\n" st_complete ; + if st_partial > 0 then + Format.fprintf out " %4d Locally validated@\n" st_partial ; + if st_extern > 0 then + Format.fprintf out " %4d Considered valid@\n" st_extern ; + if st_unknown > 0 then + Format.fprintf out " %4d To be validated@\n" st_unknown ; + if st_alarm > 0 then + Format.fprintf out " %4d Alarms emitted@\n" st_alarm ; + if st_bug > 0 then + Format.fprintf out " %4d Bugs found@\n" st_bug ; + if st_dead > 1 then + Format.fprintf out " %4d Dead properties@\n" st_dead ; + if st_dead = 1 then + Format.fprintf out " 1 Dead property@\n" ; + if st_inconsistent > 1 + then Format.fprintf out " %4d Inconsistencies@\n" st_inconsistent ; + if st_inconsistent = 1 + then Format.fprintf out " 1 Inconsistency@\n" ; + let total = + st_complete + st_partial + st_extern + st_unknown + st_alarm + st_bug + + st_dead + st_inconsistent + in + Format.fprintf out " %5d Total@\n%s@." total bar ; + + method empty = + Format.fprintf out "%s@\n--- No status to report@\n%s@." bar bar ; + +end + +let create out = (new dumper out :> Scan.inspector) + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/report/dump.mli frama-c-20111001+nitrogen+dfsg/src/report/dump.mli --- frama-c-20110201+carbon+dfsg/src/report/dump.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/dump.mli 2011-10-10 08:38:25.000000000 +0000 @@ -0,0 +1,23 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +val create : Format.formatter -> Scan.inspector diff -Nru frama-c-20110201+carbon+dfsg/src/report/Makefile.in frama-c-20111001+nitrogen+dfsg/src/report/Makefile.in --- frama-c-20110201+carbon+dfsg/src/report/Makefile.in 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/Makefile.in 2011-10-10 08:38:25.000000000 +0000 @@ -0,0 +1,66 @@ +########################################################################## +# # +# This file is part of Frama-C. # +# # +# Copyright (C) 2007-2011 # +# CEA (Commissariat � l'�nergie atomique et aux �nergies # +# alternatives) # +# # +# you can redistribute it and/or modify it under the terms of the GNU # +# Lesser General Public License as published by the Free Software # +# Foundation, version 2.1. # +# # +# It 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 Lesser General Public License for more details. # +# # +# See the GNU Lesser General Public License version 2.1 # +# for more details (enclosed in the file licenses/LGPLv2.1). # +# # +########################################################################## + +# Do not use ?= to initialize both below variables +# (fixed efficiency issue, see GNU Make manual, Section 8.11) +ifndef FRAMAC_SHARE +FRAMAC_SHARE :=$(shell frama-c -journal-disable -print-path) +endif +ifndef FRAMAC_LIBDIR +FRAMAC_LIBDIR :=$(shell frama-c -journal-disable -print-libpath) +endif + +################### +# Plug-in Setting # +################### + +PLUGIN_DIR ?=. +PLUGIN_ENABLE:=@ENABLE_REPORT@ +PLUGIN_DYNAMIC:=@DYNAMIC_REPORT@ +PLUGIN_NAME:=Report +PLUGIN_CMO:= scan dump register +PLUGIN_HAS_MLI:=yes +PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE) +PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure +#PLUGIN_DISTRIB_BIN:=no +#PLUGIN_NO_DEFAULT_TEST:=no +PLUGIN_TESTS_DIRS:=report + +################ +# Generic part # +################ + +include $(FRAMAC_SHARE)/Makefile.dynamic + +##################################### +# Regenerating the Makefile on need # +##################################### + +ifeq ("$(FRAMAC_INTERNAL)","yes") +CONFIG_STATUS_DIR=$(FRAMAC_SRC) +else +CONFIG_STATUS_DIR=. +endif + +$(Report_DIR)/Makefile: $(Report_DIR)/Makefile.in \ + $(CONFIG_STATUS_DIR)/config.status + cd $(CONFIG_STATUS_DIR) && ./config.status diff -Nru frama-c-20110201+carbon+dfsg/src/report/register.ml frama-c-20111001+nitrogen+dfsg/src/report/register.ml --- frama-c-20110201+carbon+dfsg/src/report/register.ml 2011-02-07 13:53:57.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/register.ml 2011-10-10 08:38:25.000000000 +0000 @@ -3,10 +3,8 @@ (* This file is part of Frama-C. ) ( ) ( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( INRIA (Institut National de Recherche en Informatique et en ) -( Automatique) ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) ( ) ( you can redistribute it and/or modify it under the terms of the GNU ) ( Lesser General Public License as published by the Free Software ) @@ -17,72 +15,12 @@ ( MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ) ( GNU Lesser General Public License for more details. ) ( ) -( See the GNU Lesser General Public License version v2.1 ) +( See the GNU Lesser General Public License version 2.1 ) ( for more details (enclosed in the file licenses/LGPLv2.1). ) ( *) (**************************************************************************) -(* -------------------------------------------------------------------------- ) -( --- Computes a TODO-list for properties --- ) -( -------------------------------------------------------------------------- ) - -open Cil_types -open Properties_status - -type proof = { - p_emitter : string ; - p_pending : Property.t list ; ( not yet complete ) -} - -( -------------------------------------------------------------------------- ) -( --- Utilities --- ) -( -------------------------------------------------------------------------- ) - -let compare_proof p1 p2 = - let n1 = List.length p1.p_pending in - let n2 = List.length p2.p_pending in - let c = Datatype.Int.compare n1 n2 in - if c<>0 then c else String.compare p1.p_emitter p2.p_emitter - -( -------------------------------------------------------------------------- ) -( --- Consolidation calculus with Memoization --- ) -( -------------------------------------------------------------------------- ) - -module Hip = Property.Hashtbl - -let rec get_proofs hmap ip : proof list = - try Hip.find hmap ip - with Not_found -> - Hip.add hmap ip [] ; - ( Force dependencies to be computed ) - ignore (Properties_status.strongest ip) ; - ( Now report ) - let ctree = Consolidation_tree.get ip in - let proofs = - List.fold_left - (fun ps s -> - match s.Consolidation_tree.value with - | Checked {valid=True;emitter=e} , _ -> - let hs = - List.filter - (fun s -> not (is_complete hmap s)) - s.Consolidation_tree.hypothesis - in - let hips = - List.sort - Property.compare - (List.map (fun h -> h.Consolidation_tree.property) hs) - in - { p_emitter=e ; p_pending=hips } :: ps - | _ -> ps - ) [] ctree.Consolidation_tree.status in - let ordered = List.sort compare_proof proofs in - Hip.replace hmap ip ordered ; ordered - -and is_complete hmap (s : Consolidation_tree.t) = - List.exists - (fun p -> p.p_pending=[]) - (get_proofs hmap s.Consolidation_tree.property) +open Property_status ( -------------------------------------------------------------------------- ) ( --- Plug-in Implementation --- ) @@ -97,145 +35,27 @@ module Enabled = Self.Action(struct - let option_name = "-report" - let help = "display a summary of properties status" - let kind = `Tuning - end) - -module Emitter = - Self.False(struct - let option_name = "-report-emitter" - let help = "display the list of emitters for available proofs" - let kind = `Tuning - end) - -module Pending = - Self.False(struct - let option_name = "-report-pending" - let help = "display the list of pending properties for partial proofs" - let kind = `Tuning - end) - -module OnlyValid = - Self.False(struct - let option_name = "-report-valid" - let help = "only report on validated properties" - let kind = `Tuning - end) - -let txt_unknown = " Unknown " -let txt_valid = " Valid " -let txt_partial = " Partial " -let bar = String.make 60 '-' + let option_name = "-report" + let help = "display a summary of properties status" + let kind = `Tuning + end) -let report ~partials ~completes ~untried hmap fmt title ips = - if ips <> [] then - begin - Format.fprintf fmt "%s@\n %s@\n%s@\n@\n" - bar title bar ; - let ips = List.sort Property.compare ips in - List.iter - (fun ip -> - let proofs = get_proofs hmap ip in - let status = - if proofs = [] then - ( incr untried ; txt_unknown ) - else - if List.exists (fun p -> p.p_pending=[]) proofs - then ( incr completes ; txt_valid ) - else ( incr partials ; txt_partial ) - in - let pkf = Property.get_kf ip in - (match pkf with - | None -> - Format.fprintf fmt "[%s] Global @[%a@]@\n" - status Property.pretty ip - | Some kf -> - Format.fprintf fmt "[%s] Function '%s' @[%a@]@\n" - status (Kernel_function.get_name kf) Property.pretty ip); - if Pending.get () || Emitter.get () then - List.iter - (fun p -> - begin - match Emitter.get () , Pending.get () , p.p_pending with - | _ , _ , [] -> - Format.fprintf fmt " Emitter %s [complete]@\n" - p.p_emitter - | true , false , hs -> - Format.fprintf fmt " Emitter %s [%d pending]@\n" - p.p_emitter (List.length hs) ; - | _ , true , _ -> - Format.fprintf fmt " Emitter %s:@\n" - p.p_emitter - | false , false , _ -> assert false ( englobing 'if' ) - end ; - if Pending.get () then - List.iter - (fun h -> - match Property.get_kf h , pkf with - | Some hkf, Some kf when Kernel_function.equal hkf kf -> - Format.fprintf fmt " - @[pending %a@]@\n" - Property.pretty h - | Some hkf , _ -> - Format.fprintf fmt " - @[pending %a@ from function '%s'@]@\n" - Property.pretty h (Kernel_function.get_name hkf) - | None , _ -> - Format.fprintf fmt " - @[pending global %a@]@\n" - Property.pretty h) - p.p_pending ; - Format.pp_print_flush fmt () - ) proofs - ) ips ; - Format.pp_print_newline fmt () ; - end +let bar = String.make 60 '-' -let print () = - begin - let hmap = Hip.create 131 in - let forest = Consolidation_tree.get_all () in - let globals = ref [] in - let reports = ref Kernel_function.Map.empty in - Self.feedback "Computing properties status..." ; - List.iter - (fun t -> - let ip = t.Consolidation_tree.property in - let proofs = get_proofs hmap ip in - if (if OnlyValid.get () then proofs <> [] else true) then - match Property.get_kf ip with - | None -> globals := ip :: !globals - | Some kf -> - let ipfs = - try Kernel_function.Map.find kf !reports with Not_found -> [] - in - reports := Kernel_function.Map.add kf (ip::ipfs) !reports) - forest; - Log.print_on_output "%t" - (fun fmt -> - if !globals = [] && Kernel_function.Map.is_empty !reports then - Format.fprintf fmt "No properties status@." ; - let partials = ref 0 in - let completes = ref 0 in - let untried = ref 0 in - report ~partials ~completes ~untried hmap fmt "Global Properties" !globals ; - Kernel_function.Map.iter - (fun kf ips -> - let title = - Printf.sprintf "Properties for Function '%s'" - (Kernel_function.get_name kf) - in report ~partials ~completes ~untried hmap fmt title ips - ) !reports ; - let s = !untried + !partials + !completes in - Format.fprintf fmt "%s@\n" bar ; - Format.fprintf fmt " No proofs : %4d@\n" !untried ; - Format.fprintf fmt " Partial proofs : %4d@\n" !partials ; - Format.fprintf fmt " Complete proofs : %4d@\n" !completes ; - Format.fprintf fmt " Total : %4d@\n" s ; - Format.fprintf fmt "%s@." bar ; - ) ; - end +let print () = + Self.feedback "Computing properties status..." ; + Log.print_on_output (fun fmt -> Scan.iter (Dump.create fmt)) + +let print = + Dynamic.register + ~plugin:"Report" + ~journalize:true + "print" + (Datatype.func Datatype.unit Datatype.unit) + print -let main () = - if Enabled.get () then +let main () = + if Enabled.get () then begin print () ; Enabled.clear () ; ( Hack for not printing the report after -then ) diff -Nru frama-c-20110201+carbon+dfsg/src/report/register.mli frama-c-20111001+nitrogen+dfsg/src/report/register.mli --- frama-c-20110201+carbon+dfsg/src/report/register.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/register.mli 2011-10-10 08:38:25.000000000 +0000 @@ -3,10 +3,8 @@ ( This file is part of Frama-C. ) ( ) ( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( INRIA (Institut National de Recherche en Informatique et en ) -( Automatique) ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) ( ) ( you can redistribute it and/or modify it under the terms of the GNU ) ( Lesser General Public License as published by the Free Software ) @@ -17,7 +15,7 @@ ( MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ) ( GNU Lesser General Public License for more details. ) ( ) -( See the GNU Lesser General Public License version v2.1 ) +( See the GNU Lesser General Public License version 2.1 ) ( for more details (enclosed in the file licenses/LGPLv2.1). ) ( *) (**************************************************************************) @@ -27,8 +25,12 @@ (* -------------------------------------------------------------------------- ) module Self : Plugin.S -module Enabled : Plugin.BOOL -module Emitter : Plugin.BOOL -module Pending : Plugin.BOOL +module Enabled : Plugin.Bool val print : unit -> unit + +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/report/Report.mli frama-c-20111001+nitrogen+dfsg/src/report/Report.mli --- frama-c-20110201+carbon+dfsg/src/report/Report.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/Report.mli 2011-10-10 08:38:25.000000000 +0000 @@ -3,10 +3,8 @@ ( This file is part of Frama-C. ) ( ) ( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( INRIA (Institut National de Recherche en Informatique et en ) -( Automatique) ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) ( ) ( you can redistribute it and/or modify it under the terms of the GNU ) ( Lesser General Public License as published by the Free Software ) @@ -17,7 +15,7 @@ ( MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ) ( GNU Lesser General Public License for more details. ) ( ) -( See the GNU Lesser General Public License version v2.1 ) +( See the GNU Lesser General Public License version 2.1 ) ( for more details (enclosed in the file licenses/LGPLv2.1). ) ( ) () diff -Nru frama-c-20110201+carbon+dfsg/src/report/scan.ml frama-c-20111001+nitrogen+dfsg/src/report/scan.ml --- frama-c-20110201+carbon+dfsg/src/report/scan.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/scan.ml 2011-10-10 08:38:25.000000000 +0000 @@ -0,0 +1,134 @@ +() +( ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Iterator for Report --- ) +( -------------------------------------------------------------------------- ) + +open Property_status +module E = Emitter.Usable_emitter + +class type inspector = +object + + method empty : unit + method started : unit + method global_section : unit + method function_section : Kernel_function.t -> unit + method property : Property.t -> Consolidation.t -> unit + method finished : unit + +end + +let dead_reasons (ps:Consolidation.pending) = + E.Map.fold + (fun _ -> E.Map.fold (fun _ -> Property.Set.union)) + ps Property.Set.empty + +let partial_pending (ps:Consolidation.pending) = + E.Map.map + (fun best -> E.Map.fold + (fun _ -> Property.Set.union) + best Property.Set.empty) + ps + +let rec add_property ips ip = + if not (Property.Set.mem ip !ips) then + begin + ips := Property.Set.add ip !ips ; + add_consolidation ips (Consolidation.get ip) + end + +and add_consolidation ips = function + | Consolidation.Never_tried + | Consolidation.Considered_valid + | Consolidation.Valid _ + | Consolidation.Invalid _ + | Consolidation.Inconsistent _ -> () + + | Consolidation.Valid_under_hyp ps + | Consolidation.Unknown ps + | Consolidation.Invalid_under_hyp ps + | Consolidation.Valid_but_dead ps + | Consolidation.Invalid_but_dead ps + | Consolidation.Unknown_but_dead ps -> + add_pending ips ps + +and add_pending ipref (ps:Consolidation.pending) = + E.Map.iter + (fun _ m -> + E.Map.iter + (fun _ ips -> + Property.Set.iter (add_property ipref) ips + ) m + ) ps + +let never_tried ip = + match Consolidation.get ip with + | Consolidation.Never_tried -> true + | _ -> false + +let iter (inspector:inspector) = + begin + ( Collect noticeable properties (tried + their pending) ) + let properties = ref Property.Set.empty in + Property_status.iter + (fun ip -> if not (never_tried ip) then add_property properties ip) ; + let globals = ref Property.Set.empty in + let functions = ref Kernel_function.Map.empty in + ( Dispatch properties into globals and per-function map ) + Property.Set.iter + (fun ip -> + match Property.get_kf ip with + | None -> globals := Property.Set.add ip !globals + | Some kf -> + if not (Ast_info.is_frama_c_builtin (Kernel_function.get_name kf)) + then try + let fips = Kernel_function.Map.find kf !functions in + fips := Property.Set.add ip !fips + with Not_found -> + let ips = Property.Set.singleton ip in + functions := Kernel_function.Map.add kf (ref ips) !functions) + !properties ; + ( Report a set of ip in a section ) + let report s f ips = if not (Property.Set.is_empty ips) then + ( s () ; Property.Set.iter (fun ip -> f ip (Consolidation.get ip)) ips ) + in + if Property.Set.is_empty !globals && Kernel_function.Map.is_empty !functions then + inspector#empty + else + begin + inspector#started ; + report (fun () -> inspector#global_section) inspector#property !globals ; + Kernel_function.Map.iter + (fun kf ips -> + report (fun () -> inspector#function_section kf) inspector#property !ips) + !functions ; + inspector#finished ; + end + end + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/report/scan.mli frama-c-20111001+nitrogen+dfsg/src/report/scan.mli --- frama-c-20110201+carbon+dfsg/src/report/scan.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/report/scan.mli 2011-10-10 08:38:25.000000000 +0000 @@ -0,0 +1,43 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Iterator for Report --- ) +( -------------------------------------------------------------------------- ) + +open Property_status + +class type inspector = +object + + method empty : unit + method started : unit + method global_section : unit + method function_section : Kernel_function.t -> unit + method property : Property.t -> Consolidation.t -> unit + method finished : unit + +end + +val dead_reasons : Consolidation.pending -> Property.Set.t +val partial_pending : Consolidation.pending -> Property.Set.t Emitter.Usable_emitter.Map.t +val iter : inspector -> unit diff -Nru frama-c-20110201+carbon+dfsg/src/rte/register.ml frama-c-20111001+nitrogen+dfsg/src/rte/register.ml --- frama-c-20110201+carbon+dfsg/src/rte/register.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/rte/register.ml 2011-10-10 08:38:22.000000000 +0000 @@ -20,7 +20,6 @@ ( *) (**************************************************************************) -open Db_types open Rte_parameters let start_msg () = diff -Nru frama-c-20110201+carbon+dfsg/src/rte/rte.ml frama-c-20111001+nitrogen+dfsg/src/rte/rte.ml --- frama-c-20110201+carbon+dfsg/src/rte/rte.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/rte/rte.ml 2011-10-10 08:38:22.000000000 +0000 @@ -25,13 +25,12 @@ (* should we check for plugin option -no-overflow: disable signed overflow annotation generation ? ) -open Db_types open Cil open Cil_types open Rte_parameters - + let rte_prefix = "rte" ( prefix for generated predicates (not behaviors) ) -let precond_prefix = "pre" ( prefix for generate behaviors ) +let precond_prefix = "pre" ( prefix for generated behaviors ) module Int = Abstract_interp.Int ( for integer computation ) @@ -55,8 +54,8 @@ let rec get_state kf = match find_all kf with | [] -> - add (Kernel_function.get_name kf) kf [ ] () ; - get_state kf + add (Kernel_function.get_name kf) kf [ ] () ; + get_state kf | [ _, s ] -> s | _ -> assert false @@ -105,10 +104,10 @@ let rec get_state kf = let sglobal = RteGlobalTbl.get_state kf in match find_all kf with - | [] -> add (Kernel_function.get_name kf) kf [ sglobal ] () ; - get_state kf - | [ _, s ] -> s - | _ -> assert false + | [] -> add (Kernel_function.get_name kf) kf [ sglobal ] () ; + get_state kf + | [ _, s ] -> s + | _ -> assert false end @@ -240,14 +239,25 @@ end) (PrecondAnnot_Proxy) - -( this module is used for annotation status registering in this plugin ) -module S = - Properties_status.Make_updater - (struct - let name = "RTE" - let emitter = self - end) +let emit_status = + let emitter = + Emitter.create "RTE" + ~correctness:[ DoUnsignedOverflow.parameter ; + DoAll.parameter ; + DoSignedOverflow.parameter ; + DoDownCast.parameter ; + DoDivMod.parameter ; + DoMemAccess.parameter ; + DoCalledPrecond.parameter ; + FunctionSelection.parameter + ] + ~tuning:[ Enabled.parameter ; + Print.parameter ; + ConstFold.parameter ; + Warn.parameter + ] + in + fun ppt s -> Extlib.may (Property_status.emit emitter ~hyps:[] ppt) s module Parameter_map = struct @@ -260,21 +270,21 @@ let is_one_true ~except:name_opt m = match name_opt with | None -> ( - try - Datatype.String.Map.iter - (fun _ bval -> if bval then failwith "") m - ; - false - with _ -> true - ) + try + Datatype.String.Map.iter + (fun _ bval -> if bval then failwith "") m + ; + false + with _ -> true + ) | Some name -> ( - try - Datatype.String.Map.iter - (fun n bval -> if bval && (n <> name) then failwith "") m - ; - false - with _ -> true - ) + try + Datatype.String.Map.iter + (fun n bval -> if bval && (n <> name) then failwith "") m + ; + false + with _ -> true + ) let is_true name m = try @@ -298,7 +308,7 @@ DoDownCast.name, DoDownCast.get, true, RTE_DownCast_Generated.set; ( DoCalledPrecond ) - DoCalledPrecond.name, DoCalledPrecond.get, true, + DoCalledPrecond.name, DoCalledPrecond.get, false ( NOT set on DoAll ), Called_Precond_Generated.set; ( DoUnsignedOverflow ) DoUnsignedOverflow.name, DoUnsignedOverflow.get, false ( NOT set on DoAll ), @@ -313,31 +323,31 @@ let empty_gen = List.fold_left (fun acc (opt_name,opt_fun, _, _) -> - Datatype.String.Map.add opt_name (opt_fun ()) acc) + Datatype.String.Map.add opt_name (opt_fun ()) acc) Datatype.String.Map.empty generating_opts let empty_other = List.fold_left (fun acc (opt_name,opt_fun) -> - Datatype.String.Map.add opt_name (opt_fun ()) acc ) + Datatype.String.Map.add opt_name (opt_fun ()) acc ) Datatype.String.Map.empty other_opts let gen_from_command_line_options () = let opt_state opt_fun bset_on_do_all = ( DoAll is set + bset_on_do_all = set all options to true ; - otherwise rely on option switch ) + otherwise rely on option switch ) if bset_on_do_all && (DoAll.get ()) then true else opt_fun () in List.fold_left - (fun acc (opt_name,opt_fun,bset_on_do_all,_) -> - Datatype.String.Map.add - opt_name - (opt_state opt_fun bset_on_do_all) - acc) - Datatype.String.Map.empty generating_opts + (fun acc (opt_name,opt_fun,bset_on_do_all,_) -> + Datatype.String.Map.add + opt_name + (opt_state opt_fun bset_on_do_all) + acc) + Datatype.String.Map.empty generating_opts let set_precond pmap = Datatype.String.Map.add DoCalledPrecond.name true pmap @@ -347,9 +357,9 @@ (fun acc name -> Datatype.String.Map.add name true acc) pmap [ DoSignedOverflow.name ; - DoMemAccess.name ; - DoDivMod.name ; - DoDownCast.name ] + DoMemAccess.name ; + DoDivMod.name ; + DoDownCast.name ] let set_unsignedOv pmap = Datatype.String.Map.add DoUnsignedOverflow.name true pmap @@ -357,7 +367,7 @@ let other_from_command_line_options () = List.fold_left (fun acc (opt_name,opt_fun) -> - Datatype.String.Map.add opt_name (opt_fun ()) acc) + Datatype.String.Map.add opt_name (opt_fun ()) acc) Datatype.String.Map.empty other_opts end @@ -372,10 +382,10 @@ Kernel_function.Make_Table (Datatype.Pair(Parameter_map)(Parameter_map)) (struct - let size = 97 - let name = "rte_options" - let dependencies = [ Ast.self ] - let kind = `Correctness + let size = 97 + let name = "rte_options" + let dependencies = [ Ast.self ] + let kind = `Correctness end) let find_current_gen_options kf = @@ -391,8 +401,8 @@ let rec get_state_kf kf = match RteGlobalTbl.find_all kf with | [] -> - RteGlobalTbl.add (Kernel_function.get_name kf) kf [ ] () ; - get_state_kf kf + RteGlobalTbl.add (Kernel_function.get_name kf) kf [ ] () ; + get_state_kf kf | [ _, s ] -> s | _ -> assert false @@ -400,9 +410,9 @@ let rec get_rte_state_kf kf = let sglobal = get_state_kf kf in match RteAnnotTbl.find_all kf with - | [] -> - RteAnnotTbl.add (Kernel_function.get_name kf) kf [ sglobal ] () ; - get_rte_state_kf kf + | [] -> + RteAnnotTbl.add (Kernel_function.get_name kf) kf [ sglobal ] () ; + get_rte_state_kf kf | [ _, s ] -> s | _ -> assert false @@ -410,24 +420,60 @@ let rec get_precond_state_kf kf = let sglobal = get_state_kf kf in match PrecondAnnotTbl.find_all kf with - | [] -> - PrecondAnnotTbl.add (Kernel_function.get_name kf) kf [ sglobal ] () ; - get_precond_state_kf kf - | [ _, s ] -> s - | _ -> assert false + | [] -> + PrecondAnnotTbl.add (Kernel_function.get_name kf) kf [ sglobal ] () ; + get_precond_state_kf kf + | [ _, s ] -> s + | _ -> assert false ) end ( warning ) +let fmt_warn_no_valid_fptr_deref = + format_of_string "no predicate available yet to check \ + validity of function pointer dereferencing %a" + +let fmt_warn_bitsize_over_64 = + format_of_string "bitsSize of %a > 64: not treated" + +let fmt_warn_bitsize_over_32 = + format_of_string "bitsSize of %a > 32: not treated" + +let fmt_warn_bad_bitsize = + format_of_string "problem with bitsSize of %a: not treated" + +let fmt_warn_shift_assert1 = + format_of_string "shift assert broken (signed overflow): %a" + +let fmt_warn_shift_assert2 = + format_of_string "shift assert broken (left operand should be nonnegative): %a" + +let fmt_warn_shift_assert3 = + format_of_string "shift assert broken (unsigned overflow): %a" + +let fmt_warn_shift_assert4 = + format_of_string "shift assert broken (bad right operand): %a" + +let fmt_warn_signed_downcast_assert = + format_of_string "signed downcast assert broken: %a" + +let fmt_unary_minus_assert = + format_of_string "unary minus assert broken: %a" + +let fmt_signed_overflow_assert = + format_of_string "signed overflow assert broken: %a" + +let fmt_unsigned_overflow_assert = + format_of_string "unsigned overflow assert broken: %a" + +let fmt_divisor_assert = + format_of_string "divisor assert broken: %a" + let rte_warn ?source fmt = Rte_parameters.warning ?source ~current:true ~once:true (warn) fmt -( build a "checked as false" annotation status ) -let make_check_false () = Checked { emitter = "rte" ; valid = False } -( and make_check_true () = Checked { emitter = "rte" ; valid = True } ) ;; - ( compute a term from a C expr, with the property that arithmetic operations are evaluated in Z (integers) ) @@ -455,25 +501,25 @@ let term = if cast then begin - ( expr_to_term_with_cast expr ) - ( not used since it adds casts everywhere (not pretty): - since sub-expressions are also checked for annotation, - might as well cast only top expression ) - match aterm.term_node with - | TCastE(_,_) -> ( no point in recasting ) aterm - | TConst _ -> ( constants are not cast, - though in some cases they should (big const) ) aterm - | TLval _ -> aterm - | _ -> - if (Cil.isIntegralType e_typ || Cil.isFloatingType e_typ) - then - Logic_const.term - (TCastE - (e_typ, - Logic_const.term - aterm.term_node - (Logic_utils.typ_to_logic_type e_typ))) (Ctype e_typ) - else aterm + ( expr_to_term_with_cast expr ) + ( not used since it adds casts everywhere (not pretty): + since sub-expressions are also checked for annotation, + might as well cast only top expression ) + match aterm.term_node with + | TCastE(_,_) -> ( no point in recasting ) aterm + | TConst _ -> ( constants are not cast, + though in some cases they should (big const) ) aterm + | TLval _ -> aterm + | _ -> + if (Cil.isIntegralType e_typ || Cil.isFloatingType e_typ) + then + Logic_const.term + (TCastE + (e_typ, + Logic_const.term + aterm.term_node + (Logic_utils.typ_to_logic_type e_typ))) (Ctype e_typ) + else aterm end else aterm in @@ -484,10 +530,10 @@ let t1,t2 = expr_to_term ~cast:false expr, expr_to_term ~cast:true expr in debug ~level:2 - "output integer term: %a (%a)\n" Cil.d_term t1 Cil.d_logic_type t1.term_type + "output integer term: %a (%a)\n" Cil.d_term t1 Cil.d_logic_type t1.term_type ; debug ~level:2 - "output (C cast) term: %a (%a)\n" Cil.d_term t2 Cil.d_logic_type t2.term_type + "output (C cast) term: %a (%a)\n" Cil.d_term t2 Cil.d_logic_type t2.term_type ; ) term @@ -498,12 +544,12 @@ let cexpr = constFold true expr in match cexpr.enode with | Const c -> - let rec get_constant_expr_val e = - match e with - | CChr c -> get_constant_expr_val (charConstToInt c) - | CInt64 (d64,_,_) -> Some d64 - | _ -> None - in get_constant_expr_val c + let rec get_constant_expr_val e = + match e with + | CChr c -> get_constant_expr_val (charConstToInt c) + | CInt64 (d64,_,_) -> Some d64 + | _ -> None + in get_constant_expr_val c | _ -> None type tOff = MyField of fieldinfo | MyIndex of exp @@ -516,11 +562,12 @@ let get_lval_assertion (lv : lval) = (* one has to build assertions for: - pointer dereferencing: only if lval host is of the form (Mem expr) - - array access: several may occur, one for each offset of the form (Index _,_) + - array access: several may occur, one for each offset of the form (Index + _,_) ) ( so we : A. compute all assertions for array accesses by - 1. transforming the offset recurvise structure + 1. transforming the offset recursive structure in an ad hoc list (offsets_as_list) 2. keeping offsets which are array accesses (all_array_offsets) 3. rebuilding Cil offsets from these (final_array_offsets) @@ -533,93 +580,68 @@ let (lhost, init_offset) = lv in let rec fetch_all_offsets acc off = match off with - | NoOffset -> acc - | Field (fi, next_off) -> fetch_all_offsets ((MyField fi) :: acc) next_off - | Index (e, next_off) -> fetch_all_offsets ((MyIndex e) :: acc) next_off - in let offsets_as_list = List.rev (fetch_all_offsets [] init_offset) - in let all_array_offsets = - fst ( - List.fold_left - (fun (acc_off,acc_prefix) moff -> - match moff with - | MyIndex _ -> - ((moff :: acc_prefix) :: acc_off, moff :: acc_prefix) - | _ -> (acc_off, moff :: acc_prefix) - ) ([],[]) offsets_as_list) - - in let rec build_offset_from_list off_list = + | NoOffset -> acc + | Field (fi, next_off) -> fetch_all_offsets ((MyField fi) :: acc) next_off + | Index (e, next_off) -> fetch_all_offsets ((MyIndex e) :: acc) next_off + in + let offsets_as_list = List.rev (fetch_all_offsets [] init_offset) in + let all_array_offsets, _ = + List.fold_left + (fun (acc_off,acc_prefix) moff -> + match moff with + | MyIndex _ -> + ((moff :: acc_prefix) :: acc_off, moff :: acc_prefix) + | _ -> (acc_off, moff :: acc_prefix)) + ([],[]) + offsets_as_list + in + let rec build_offset_from_list off_list = match off_list with | [] -> NoOffset | (MyField fi) :: tl -> Field (fi, build_offset_from_list tl) | (MyIndex e) :: tl -> Index (e, build_offset_from_list tl) - in let final_array_offsets = + in + let final_array_offsets = List.map (fun off_list -> - build_offset_from_list (List.rev off_list) + build_offset_from_list (List.rev off_list) ) all_array_offsets (* in let () = debug "Final list of offsets is\n" ; List.iter (fun off -> debug "%a\n" d_offset off) final_array_offsets ) - in let final_array_lvals = (List.map (fun off -> (lhost,off)) final_array_offsets) - in let final_array_terms = - List.fold_left - (fun acc lv -> - if isFunctionType (typeOfLval lv) then ( - rte_warn "no predicate available yet to check \ - validity of function pointer dereferencing %a" - Cil.d_lval lv - ; - acc) - else - (translate_C_expr_to_term ~cast:false - (mkAddrOf ~loc:(CurrentLoc.get())lv)) - :: acc) + in + let final_array_lvals = + List.map (fun off -> (lhost,off)) final_array_offsets in + let final_array_terms = + List.fold_left + (fun acc lv -> + if isFunctionType (typeOfLval lv) then begin + rte_warn fmt_warn_no_valid_fptr_deref + Cil.d_lval lv; + acc + end else + translate_C_expr_to_term ~cast:false + (mkAddrOf ~loc:(CurrentLoc.get())lv) + :: acc) [] final_array_lvals - in let final_terms = - match lv with - | Mem exp, _ -> - if isFunctionType (typeOfLval lv) then ( - rte_warn "no predicate available yet to check \ -validity of function pointer dereferencing %a" - Cil.d_lval lv - ; - final_array_terms - ) else - (translate_C_expr_to_term ~cast:false exp) :: final_array_terms - | Var _, _ -> final_array_terms - in List.map (fun t -> (Logic_const.pvalid t, None) ) final_terms - -( compute min/max representable signed integer with bit-length sz (<= 64) ) -let get_signed_min sz = - assert(sz <= 64); - let min64 = Int64.min_int - and shift_value = 64 - sz in - if shift_value > 0 - then Int64.shift_right min64 shift_value - else min64 - -let get_signed_max sz = - assert(sz <= 64); - let max64 = Int64.max_int - and shift_value = 64 - sz in - if shift_value > 0 - then Int64.shift_right max64 shift_value - else max64 - -( compute max representable unsigned integer - with bit-length sz (<= 32 for the time being) ) -let get_unsigned_max sz = - assert(sz <= 32); - let max32 = Int64.of_string "0xffffffff" - and shift_value = 32 - sz - in - if shift_value > 0 - then Int64.shift_right max32 shift_value - else max32 - + in + let final_terms = + match lv with + | Mem exp, _ -> + if isFunctionType (typeOfLval lv) then begin + rte_warn fmt_warn_no_valid_fptr_deref + Cil.d_lval lv; + final_array_terms + end else + translate_C_expr_to_term ~cast:false exp :: final_array_terms + | Var _, _ -> final_array_terms + in + List.map + (fun t -> (Logic_const.pvalid t, None)) + final_terms ( assertions for bounding a term ) let assertion_le term bound = Logic_const.prel (Rle, term, Cil.lconstant bound) @@ -632,29 +654,28 @@ let size = bitsSizeOf t in if (size > 64) then ( ( should never happen ) - rte_warn "bitsSize of %a > 64: not treated" d_exp expr ; + rte_warn fmt_warn_bitsize_over_64 d_exp expr ; [] ) else - let minType = get_signed_min size in + let minType = min_signed_number size in let assertion () = - let term = translate_C_expr_to_term expr - in Logic_const.prel (Rneq, term, Cil.lconstant minType) + let term = translate_C_expr_to_term expr + in Logic_const.prel (Rneq, term, Cil.lconstant minType) in - if simplify_constants then ( - match get_expr_val expr with - | Some a64 -> ( constant operand ) - if Int64.compare a64 minType = 0 then ( - let assertion = assertion () - in - if warning then - rte_warn "unary minus assert broken: %a" d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - ) - else [] - | None -> [ (assertion (), None) ] - ) else [ (assertion (), None) ] + if simplify_constants then ( + match get_expr_val expr with + | Some a64 -> ( constant operand ) + if My_bigint.equal a64 minType then begin + let assertion = assertion () in + if warning then + rte_warn fmt_unary_minus_assert + d_predicate_named assertion; + [ assertion, Some Property_status.False_if_reachable ] + end else + [] + | None -> [ (assertion (), None) ] + ) else [ (assertion (), None) ] ( assertions for multiplication/addition/subtraction signed overflow ) let get_multsubadd_assertion @@ -668,93 +689,96 @@ let size = bitsSizeOf t in if (size > 64) then ( ( should never happen ) - rte_warn "bitsSize of %a > 64: not treated" d_exp full_expr ; - [] - ) + rte_warn fmt_warn_bitsize_over_64 d_exp full_expr ; + [] + ) else - let (minType,maxType) = (get_signed_min size, get_signed_max size) in + let (minType,maxType) = (min_signed_number size, max_signed_number size) + in let full_add_term () = - ( no cast to int since we check "true result" which is an integer ) - let term1 = translate_C_expr_to_term ~cast:false expr1 - and term2 = translate_C_expr_to_term ~cast:false expr2 - in Logic_const.term (TBinOp (op, term1,term2)) (Ctype t) + ( no cast to int since we check "true result" which is an integer ) + let term1 = translate_C_expr_to_term ~cast:false expr1 + and term2 = translate_C_expr_to_term ~cast:false expr2 + in Logic_const.term (TBinOp (op, term1,term2)) (Ctype t) in let assertion_le () = assertion_le (full_add_term ()) maxType and assertion_ge () = assertion_ge (full_add_term ()) minType in - let full_assertion () = Logic_const.pand (assertion_le (), assertion_ge ()) + let full_assertion () = + Logic_const.pand (assertion_le (), assertion_ge ()) in - if simplify_constants then ( - match get_expr_val expr1, get_expr_val expr2 with - | Some a64, Some b64 -> ( both operands are constant ) - let big_a64 = Int.of_int64 a64 - and big_b64 = Int.of_int64 b64 - in - if op = MinusA then - let big_diff = Int.sub big_a64 big_b64 - in if Int.compare big_diff (Int.of_int64 minType) < 0 then - let assertion = assertion_ge () - in - if warning then - rte_warn - "signed overflow assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else [ ] - else if op = PlusA then - let big_add = Int.add big_a64 big_b64 - in if Int.compare big_add (Int.of_int64 maxType) > 0 then - let assertion = assertion_le () - in - if warning then - rte_warn - "signed overflow assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else [ ] - else ( - assert(op = Mult) ; - let big_mult = Int.mul big_a64 big_b64 - in let b_ov = (Int.compare big_mult (Int.of_int64 maxType) > 0) - in if b_ov then - let assertion = assertion_le () - in - if warning then - rte_warn - "signed overflow assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else let b_uv = (Int.compare big_mult (Int.of_int64 minType) < 0) - in if b_uv then - let assertion = assertion_ge () - in - if warning then - rte_warn - "signed overflow assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else [ ] - ) - | Some a64, None - | None, Some a64 -> ( one operand is constant ) - if op = MinusA then [ (assertion_ge (), None) ] - else if op = PlusA then [ (assertion_le (), None) ] - else ( - assert(op = Mult); - ( multiplying by 1 or 0 if not dangerous ) - if (Int64.compare a64 Int64.zero = 0) || - (Int64.compare a64 Int64.one = 0) then [] - else - ( multiplying by -1 is dangerous (albeit seldom) ) - if (Int64.compare a64 (Int64.of_int (-1)) = 0) then - [ (assertion_le (), None) ] - else [ (full_assertion (), None) ] - ) - | None,None -> [ (full_assertion (), None) ] ( no operand is a constant ) - ) else [ (full_assertion (), None) ] + if simplify_constants then begin + match get_expr_val expr1, get_expr_val expr2 with + | Some a64, Some b64 -> ( both operands are constant ) + let big_a64 = a64 + and big_b64 = b64 + in + if op = MinusA then + let big_diff = Int.sub big_a64 big_b64 + in if Int.lt big_diff minType then + let assertion = assertion_ge () in + if warning then + rte_warn + fmt_signed_overflow_assert + d_predicate_named assertion; + [ assertion, Some Property_status.False_if_reachable ] + else + [ ] + else if op = PlusA then + let big_add = Int.add big_a64 big_b64 in + if Int.gt big_add maxType then + let assertion = assertion_le () in + if warning then + rte_warn + fmt_signed_overflow_assert + d_predicate_named assertion; + [ assertion, Some Property_status.False_if_reachable ] + else + [ ] + else ( + assert(op = Mult) ; + let big_mult = Int.mul big_a64 big_b64 in + let b_ov = Int.gt big_mult maxType in + if b_ov then + let assertion = assertion_le () in + if warning then + rte_warn + fmt_signed_overflow_assert + d_predicate_named assertion ; + [ assertion, Some Property_status.False_if_reachable ] + else + let b_uv = Int.lt big_mult minType in + if b_uv then + let assertion = assertion_ge () in + if warning then + rte_warn + fmt_signed_overflow_assert + d_predicate_named assertion ; + [ assertion, Some Property_status.False_if_reachable ] + else [ ]) + | Some a64, None + | None, Some a64 -> ( one operand is constant ) + if op = MinusA then + [ assertion_ge (), None ] + else if op = PlusA then + [ assertion_le (), None ] + else begin + assert(op = Mult); + ( multiplying by 1 or 0 if not dangerous ) + if (My_bigint.equal a64 My_bigint.zero) || + (My_bigint.equal a64 My_bigint.one) + then [] + else + ( multiplying by -1 is dangerous (albeit seldom) ) + if My_bigint.equal a64 My_bigint.minus_one then + [ assertion_le (), None ] + else + [ full_assertion (), None ] + end + | None,None -> + ( no operand is a constant ) + [ full_assertion (), None ] + end else + [ full_assertion (), None ] ( assertions for multiplication/addition/subtraction unsigned overflow ) ( this is allowed by C and NOT a runtime-error ) @@ -769,80 +793,76 @@ let size = bitsSizeOf t in if (size > 32) then ( ( could happen: but then it's not possible yet to represent the maximum - possible value of the domain (2^64 - 1) as a Cil constant - (see TODO in cil_types.mli) + possible value of the domain (2^64 - 1) as a Cil constant + (see TODO in cil_types.mli) ) - rte_warn "bitsSize of %a > 32: not treated" d_exp full_expr ; - [] - ) + rte_warn fmt_warn_bitsize_over_32 d_exp full_expr ; + [] + ) else - let (minType,maxType) = (Int64.zero, get_unsigned_max size) in + let (minType,maxType) = My_bigint.zero, max_unsigned_number size in let full_add_term () = - ( no cast to int since we check "true result" which is an integer ) - let term1 = translate_C_expr_to_term ~cast:false expr1 - and term2 = translate_C_expr_to_term ~cast:false expr2 - in Logic_const.term (TBinOp (op, term1,term2)) (Ctype t) + ( no cast to int since we check "true result" which is an integer ) + let term1 = translate_C_expr_to_term ~cast:false expr1 + and term2 = translate_C_expr_to_term ~cast:false expr2 + in Logic_const.term (TBinOp (op, term1,term2)) (Ctype t) in let assertion () = - if op = MinusA then - assertion_ge (full_add_term ()) minType - else - assertion_le (full_add_term ()) maxType - in - if simplify_constants then ( - match get_expr_val expr1, get_expr_val expr2 with - | Some a64, Some b64 -> ( both operands are constant ) - let big_a64 = Int.of_int64 a64 - and big_b64 = Int.of_int64 b64 - in - if op = MinusA then - let big_diff = Int.sub big_a64 big_b64 - in if Int.compare big_diff (Int.of_int64 minType) < 0 then - let assertion = assertion () in - if warning then - rte_warn - "unsigned overflow assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else [ ] - else if op = PlusA then - let big_add = Int.add big_a64 big_b64 - in if Int.compare big_add (Int.of_int64 maxType) > 0 then - let assertion = assertion () in - if warning then - rte_warn - "unsigned overflow assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else [ ] - else ( - assert(op = Mult) ; - let big_mult = Int.mul big_a64 big_b64 - in let () = assert(Int.compare big_mult Int.zero >= 0) - in let b_ov = (Int.compare big_mult (Int.of_int64 maxType) > 0) - in - if b_ov then - let assertion = assertion () in - if warning then - rte_warn - "unsigned overflow assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else [ ] - ) - | Some a64, None - | None, Some a64 -> ( one operand is constant ) - if op = Mult then ( - ( multiplying by 1 or 0 if not dangerous ) - if (Int64.compare a64 Int64.zero = 0) || - (Int64.compare a64 Int64.one = 0) - then [] - else [ (assertion (), None) ] - ) else [ (assertion (), None) ] - | None,None -> [ (assertion (), None) ] ( no operand is a constant ) - ) else [ (assertion (), None) ] + if op = MinusA then + assertion_ge (full_add_term ()) minType + else + assertion_le (full_add_term ()) maxType + in + if simplify_constants then begin + match get_expr_val expr1, get_expr_val expr2 with + | Some big_a64, Some big_b64 -> ( both operands are constant ) + if op = MinusA then + let big_diff = Int.sub big_a64 big_b64 + in + if Int.lt big_diff minType then + let assertion = assertion () in + if warning then + rte_warn + fmt_unsigned_overflow_assert + d_predicate_named assertion; + [ assertion, Some Property_status.False_if_reachable ] + else [ ] + else if op = PlusA then + let big_add = Int.add big_a64 big_b64 in + if Int.gt big_add maxType then + let assertion = assertion () in + if warning then + rte_warn + fmt_unsigned_overflow_assert + d_predicate_named assertion; + [ assertion, Some Property_status.False_if_reachable ] + else [ ] + else ( + assert(op = Mult) ; + let big_mult = Int.mul big_a64 big_b64 in + let () = assert(Int.compare big_mult Int.zero >= 0) in + let b_ov = Int.gt big_mult maxType in + if b_ov then + let assertion = assertion () in + if warning then + rte_warn + fmt_unsigned_overflow_assert + d_predicate_named assertion ; + [ assertion, Some Property_status.False_if_reachable ] + else [ ]) + | Some a64, None + | None, Some a64 -> ( one operand is constant ) + if op = Mult then begin + ( multiplying by 1 or 0 if not dangerous ) + if My_bigint.equal a64 My_bigint.zero + || My_bigint.equal a64 My_bigint.one + then [] + else [ assertion (), None ] + end else [ assertion (), None ] + | None, None -> + ( no operand is a constant ) + [ assertion (), None ] + end else + [ assertion (), None ] ( assertions for division and modulo (divisor is 0) ) let get_divmod_assertion @@ -850,28 +870,29 @@ ~warning:warning divisor_expr = ( division or modulo: overflow occurs when divisor is equal to zero ) - let badValDivisor = Int64.zero - in let assertion () = - let term = translate_C_expr_to_term divisor_expr - in Logic_const.prel (Rneq, term, Cil.lconstant badValDivisor) - in if simplify_constants then ( - match get_expr_val divisor_expr with - | None -> ( divisor is not a constant (or it's value has not been computed) ) - [ (assertion (), None) ] - | Some v64 -> - if Int64.compare v64 badValDivisor = 0 then - ( divide by 0 ) - let assertion = assertion () - in - if warning then - rte_warn "divisor assert broken: %a" d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - else - ( divide by constant which is not 0 ) - ( nothing to assert ) - [] - ) else [ (assertion (), None) ] + let badValDivisor = My_bigint.zero in + let assertion () = + let term = translate_C_expr_to_term divisor_expr in + Logic_const.prel (Rneq, term, Cil.lconstant badValDivisor) + in + if simplify_constants then begin + match get_expr_val divisor_expr with + | None -> ( divisor is not a constant (or it's value has not + been computed) ) + [ assertion (), None ] + | Some v64 -> + if My_bigint.equal v64 badValDivisor then + ( divide by 0 ) + let assertion = assertion () in + if warning then + rte_warn fmt_divisor_assert d_predicate_named assertion ; + [ assertion, Some Property_status.False_if_reachable ] + else + ( divide by constant which is not 0 ) + ( nothing to assert ) + [] + end else + [ assertion (), None ] ( assertion for signed division overflow ) let get_signed_div_assertion @@ -884,91 +905,86 @@ represented in two's completement. Nothing done for modulo (the result of TYPE_MIN % -1 is 0, which does not overflow) Still it may be dangerous on a number of compilers / architectures - (modulo may be performed in parallel with divison) + (modulo may be performed in parallel with division) ) let t = Cil.typeOf divisor_expr in let size = bitsSizeOf t in - (* check dividend_expr / divisor_expr : if constants ... ) - if (size > 64) then ( - ( should never happen ) - rte_warn "bitsSize of %a > 64: not treated" d_exp divisor_expr ; - [] - ) - else - let badValDividend = - ( compute smallest representable "size bits" (signed) integer ) - get_signed_min size -( - let min64 = Int64.min_int - and shiftright_value = 64 - size - in if shiftright_value > 0 then Int64.shift_right min64 shiftright_value else min64 -) - and badValDivisor = Int64.minus_one - in let assert_for_divisor () = - Logic_const.prel - (Req, translate_C_expr_to_term divisor_expr, Cil.lconstant badValDivisor) - and assert_for_dividend () = - Logic_const.prel - (Req, - translate_C_expr_to_term dividend_expr, Cil.lconstant badValDividend) - in let assert_not_both () = - Logic_const.pnot - (Logic_const.pand (assert_for_divisor (), assert_for_dividend ())) - in - if simplify_constants then ( - let problem_with_divisor () = - match get_expr_val divisor_expr with - | None -> (false,false) - | Some c64 -> - if Int64.compare c64 badValDivisor = 0 - then (true,true) - else (true,false) - and problem_with_dividend () = - match get_expr_val dividend_expr with - | None -> (false,false) - | Some c64 -> - if Int64.compare c64 badValDividend = 0 - then (true,true) - else (true,false) - in - match problem_with_divisor (), problem_with_dividend () with - | (false,_), (false,_) -> ( neither divisor nor dividend is constant ) - ( Printf.eprintf "neither divisor nor dividend is constant\n"; - flush stderr; ) - [ (assert_not_both (), None) ] - | (true,true), (true,true) -> - ( divisor and dividend are constant and have both bad values ) - ( Printf.eprintf - "divisor and dividend are constant and have both bad values\n"; - flush stderr ; ) - let assertion = assert_not_both () - in - if warning then - rte_warn - "signed overflow assert broken: %a" d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - | (true,false), _ - | _ , (true,false) -> - ( one of divisor or dividend is constant and has a good value ) - ( Printf.eprintf - "one of divisor or dividend is constant and has a good value\n"; - flush stderr; ) - [] - | (true,true), (false,_) -> - ( divisor is constant and has bad value, dividend is not constant ) - ( Printf.eprintf - "divisor is constant and has bad value, dividend is not constant\n"; - flush stderr; ) - [ (Logic_const.pnot (assert_for_dividend ()), None) ] - | (false,_), (true,true) -> - ( divisor is not constant, dividend is constant and has bad value ) - ( Printf.eprintf - "divisor is not constant, dividend is constant and has bad value\n"; - flush stderr; ) - [ (Logic_const.pnot (assert_for_divisor ()), None) ] - ) else [ (assert_not_both (), None) ] + ( check dividend_expr / divisor_expr : if constants ... ) + if (size > 64) then ( + ( should never happen ) + rte_warn fmt_warn_bitsize_over_64 d_exp divisor_expr ; + [] + ) + else + let badValDividend = + ( compute smallest representable "size bits" (signed) integer ) + min_signed_number size + ( + let min64 = Int64.min_int + and shiftright_value = 64 - size + in if shiftright_value > 0 then Int64.shift_right min64 shiftright_value else min64 + ) + and badValDivisor = My_bigint.minus_one + in let assert_for_divisor () = + Logic_const.prel + (Req, translate_C_expr_to_term divisor_expr, Cil.lconstant badValDivisor) + and assert_for_dividend () = + Logic_const.prel + (Req, + translate_C_expr_to_term dividend_expr, Cil.lconstant badValDividend) + in let assert_not_both () = + Logic_const.pnot + (Logic_const.pand (assert_for_divisor (), assert_for_dividend ())) + in + if simplify_constants then ( + let problem_with_divisor () = + match get_expr_val divisor_expr with + | None -> (false,false) + | Some c64 -> + if My_bigint.equal c64 badValDivisor then (true,true) + else (true,false) + and problem_with_dividend () = + match get_expr_val dividend_expr with + | None -> (false,false) + | Some c64 -> + if My_bigint.equal c64 badValDividend then (true,true) + else (true,false) + in + match problem_with_divisor (), problem_with_dividend () with + | (false,_), (false,_) -> + ( neither divisor nor dividend is constant ) + ( Printf.eprintf "neither divisor nor dividend is constant\n"; + flush stderr; ) + [ assert_not_both (), None ] + | (true,true), (true,true) -> + ( divisor and dividend are constant and have both bad values ) + ( Printf.eprintf + "divisor and dividend are constant and have both bad values\n"; + flush stderr ; ) + let assertion = assert_not_both () + in + if warning then + rte_warn + fmt_signed_overflow_assert + d_predicate_named assertion ; + [ assertion, Some Property_status.False_if_reachable ] + | (true,false), _ + | _ , (true,false) -> + ( one of divisor or dividend is constant and has a good value ) + [] + | (true,true), (false,_) -> + ( divisor is constant and has bad value, dividend is not + constant ) + [ Logic_const.pnot (assert_for_dividend ()), + None ] + | (false,_), (true,true) -> + ( divisor is not constant, dividend is constant and has bad + value ) + [ Logic_const.pnot (assert_for_divisor ()), + None ]) + else + [ assert_not_both (), None ] ( assertions for bitwise left shift unsigned overflow ) ( this is allowed by C and NOT a runtime-error ) @@ -979,49 +995,41 @@ ( result should be representable in result type ) let t = Cil.typeOf exp in let size = bitsSizeOf t in - let () = - if not (size <= 32) - ( 64 bits size "requires" representing a constant - which does not hold in a Cil constant - (as long as it remains an int64 and not a big integer) ) - then rte_warn "problem with bitsSize of %a: not treated" d_exp exp ; - in let maxValResult = ( compute greatest reprensentable "size bits" unsigned integer ) - get_unsigned_max size + let maxValResult = + ( compute greatest reprensentable "size bits" unsigned integer ) + max_unsigned_number size in let ov_assertion () = - let term = translate_C_expr_to_term ~cast:false exp - in ( unsigned result is representable in result type if loperand times 2^roperand - (where loperand and roperand are nonnegative), - which should be equal to term (obtained with a shift), - is less than the maximal value for the result type ) - ( no cast to int since we check "true result" which is an integer) - Logic_const.prel (Rle, term, Cil.lconstant maxValResult) - in let problem_with_ov_assertion () = - if simplify_constants then ( - match get_expr_val loperand, get_expr_val roperand with - | None,_ - | _, None -> (false,false) - | Some lval64, Some rval64 -> - ( both operands are constant: - check result is representable in result type ) - let result_true_val = - Int.shift_left (Int.of_int64 lval64) (Int.of_int64 rval64) - in - if Int.compare result_true_val (Int.of_int64 maxValResult) > 0 - then (true,false) ( constant operators and assertion does not hold ) - else (true,true) ( constant operators and assertion holds ) - ) else (false,false) - in - match problem_with_ov_assertion () with - | (true,false) -> + let term = translate_C_expr_to_term ~cast:false exp + in ( unsigned result is representable in result type if loperand times 2^roperand + (where loperand and roperand are nonnegative), + which should be equal to term (obtained with a shift), + is less than the maximal value for the result type ) + ( no cast to int since we check "true result" which is an integer) + Logic_const.prel (Rle, term, Cil.lconstant maxValResult) + in let problem_with_ov_assertion () = + if simplify_constants then ( + match get_expr_val loperand, get_expr_val roperand with + | None,_ + | _, None -> (false,false) + | Some lval64, Some rval64 -> + ( both operands are constant: + check result is representable in result type ) + let result_true_val = Int.shift_left lval64 rval64 in + if Int.gt result_true_val maxValResult then + (true,false)( constant operators and assertion does not hold ) + else (true,true)( constant operators and assertion holds ) + ) else (false,false) + in + match problem_with_ov_assertion () with + | (true,false) -> let assertion = ov_assertion () in - if warning then ( - rte_warn - "shift assert broken (unsigned overflow): %a" d_predicate_named assertion - ) - ; - [ (assertion, Some (make_check_false())) ] - | (true,true) -> [ ] - | (false,_) -> [ (ov_assertion (), None) ] + if warning then + rte_warn + fmt_warn_shift_assert3 + d_predicate_named assertion; + [ assertion, Some Property_status.False_if_reachable ] + | (true,true) -> [ ] + | (false,_) -> [ ov_assertion (), None ] ( generic assertion for bitwise left/right shift on right operand ) @@ -1031,36 +1039,37 @@ ~warning:warning exp roperand = let t = Cil.typeOf exp in - let size = bitsSizeOf t - in let size64 = Int64.of_int size - in let right_operand_assertion () = - let term = translate_C_expr_to_term roperand - in - Logic_const.pand - (Logic_const.prel (Rge, term, Cil.lzero ()), - Logic_const.prel (Rlt, term, Cil.lconstant size64)) - in let problem_with_operand_assertion () = - if simplify_constants then ( - match get_expr_val roperand with - | None -> (false,false) - | Some c64 -> - ( right operand is constant: - check it is nonnegative and stricly less than size ) - if (Int64.compare c64 size64 < 0) && (Int64.compare c64 Int64.zero >= 0) - then (true,true) ( constant operator and assertion holds ) - else (true,false) ( constant operator and assertion does not hold ) - ) else (false,false) - in match problem_with_operand_assertion () with - | (true,false) -> - let assertion = right_operand_assertion () in - if warning then ( - rte_warn - "shift assert broken (bad right operand): %a" d_predicate_named assertion - ) - ; - ([ (assertion, Some (make_check_false ())) ], false) - | (true,true) -> ([ ], true) - | (false,_) -> ([ (right_operand_assertion (), None) ], true) + let size = bitsSizeOf t in + let size64 = My_bigint.of_int size in + let right_operand_assertion () = + let term = translate_C_expr_to_term roperand in + Logic_const.pand + (Logic_const.prel (Rge, term, Cil.lzero ()), + Logic_const.prel (Rlt, term, Cil.lconstant size64)) + in + let problem_with_operand_assertion () = + if simplify_constants then ( + match get_expr_val roperand with + | None -> (false,false) + | Some c64 -> + ( right operand is constant: + check it is nonnegative and stricly less than size ) + if (My_bigint.lt c64 size64) && (My_bigint.ge c64 My_bigint.zero) + then (true,true) ( constant operator and assertion holds ) + else (true,false) ( constant operator and assertion does not hold ) + ) else (false,false) + in + match problem_with_operand_assertion () with + | (true,false) -> + let assertion = right_operand_assertion () in + if warning then + rte_warn + fmt_warn_shift_assert4 + d_predicate_named assertion; + [ assertion, Some Property_status.False_if_reachable ], false + | (true,true) -> [ ], true + | (false,_) -> + [ right_operand_assertion (), None ], true ( assertions for bitwise left/right shift signed overflow ) @@ -1079,88 +1088,87 @@ let size = bitsSizeOf t in let () = if not(size = bitsSizeOf (Cil.typeOf loperand) && size <= 64) - ( size of result type should be size of left (promoted) operand ) + ( size of result type should be size of left (promoted) operand ) then ( - rte_warn "problem with bitsSize of %a: not treated" d_exp exp ; + rte_warn fmt_warn_bad_bitsize d_exp exp ; ) in - let maxValResult = ( compute greatest representable "size bits" (signed) integer ) - get_signed_max size -( + let maxValResult = + (* compute greatest representable "size bits" (signed) integer ) + max_signed_number size + ( let max64 = Int64.max_int and shiftright_value = 64 - size - in if shiftright_value > 0 then Int64.shift_right max64 shiftright_value else max64 -) - in let assertion_2 () = - let term = translate_C_expr_to_term loperand - in Logic_const.prel (Rge, term, Cil.lzero ()) - and assertion_3 () = - let term = translate_C_expr_to_term ~cast:false exp - in ( signed result is representable in result type if loperand times 2^roperand - (where loperand and roperand are nonnegative), - which should be equal to term (obtained with a shift), - is less than the maximal value for the result type ) - ( no cast to int since we check "true result" which is an integer) - Logic_const.prel (Rle, term, Cil.lconstant maxValResult) - in let problem_with_assertion_2 () = - if simplify_constants then ( - match get_expr_val loperand with - | None -> (false,false) - | Some c64 -> - ( left operand is constant: check it is nonnegative ) - if (Int64.compare c64 Int64.zero >= 0) - then (true, true) ( constant operator and assertion holds ) - else (true,false) ( constant operator and assertion does not hold ) - ) else (false,false) - and problem_with_assertion_3 () = - if simplify_constants then ( - match get_expr_val loperand, get_expr_val roperand with - | None,_ - | _, None -> (false,false) - | Some lval64, Some rval64 -> - ( both operands are constant: - check result is representable in result type ) - if (Int64.compare lval64 Int64.zero <= 0) || - (Int64.compare rval64 (Int64.of_int 64) >= 0) then - (true,false) ( constant operators and assertion does not hold ) - else - let result_true_val = - Int.shift_left (Int.of_int64 lval64) (Int.of_int64 rval64) - in - if Int.compare result_true_val (Int.of_int64 maxValResult) > 0 - then (true,false) ( constant operators and assertion does not hold ) - else (true,true) ( constant operators and assertion holds ) - ) else (false,false) - in let proceed_with_assertion_3 lassert = - if (shiftop = Shiftlt) then ( - match problem_with_assertion_3 () with - | (true,false) -> - let assertion = assertion_3 () in - if warning then ( - rte_warn - "shift assert broken (signed overflow): %a" - d_predicate_named assertion - ) - ; - ((assertion, Some (make_check_false ())))::lassert - | (true,true) -> lassert - | (false,_) -> (assertion_3 (), None)::lassert - ) else lassert + in if shiftright_value > 0 then Int64.shift_right max64 shiftright_value else max64 ) in - match problem_with_assertion_2 () with + let assertion_2 () = + let term = translate_C_expr_to_term loperand in Logic_const.prel (Rge, term, Cil.lzero ()) + and assertion_3 () = + let term = translate_C_expr_to_term ~cast:false exp in + (* signed result is representable in result type if loperand + times 2^roperand (where loperand and roperand are nonnegative), + which should be equal to term (obtained with a shift), + is less than the maximal value for the result type ) + ( no cast to int since we check "true result" which is an integer) + Logic_const.prel (Rle, term, Cil.lconstant maxValResult) + in + let problem_with_assertion_2 () = + if simplify_constants then ( + match get_expr_val loperand with + | None -> (false,false) + | Some c64 -> + ( left operand is constant: check it is nonnegative ) + if My_bigint.ge c64 My_bigint.zero + then (true, true) ( constant operator and assertion holds ) + else (true,false) ( constant operator and assertion does not hold ) + ) else (false,false) + and problem_with_assertion_3 () = + if simplify_constants then ( + match get_expr_val loperand, get_expr_val roperand with + | None,_ + | _, None -> (false,false) + | Some lval64, Some rval64 -> + ( both operands are constant: + check result is representable in result type ) + if (My_bigint.le lval64 My_bigint.zero) + || (My_bigint.ge rval64 (My_bigint.of_int 64)) then + (true,false)( constant operators and assertion does not hold ) + else + let result_true_val = Int.shift_left lval64 rval64 in + if Int.gt result_true_val maxValResult + then (true,false) + ( constant operators and assertion does not hold ) + else (true,true) ( constant operators and assertion holds )) + else (false,false) + in + let proceed_with_assertion_3 lassert = + if (shiftop = Shiftlt) then begin + match problem_with_assertion_3 () with | (true,false) -> - let assertion = assertion_2 () in - if warning then ( - rte_warn - "shift assert broken (left operand should be nonnegative): %a" - d_predicate_named assertion - ) - ; - ( do not proceed with assertion 3: left operand is negative, - hence result is implementation defined anyway for left shift ) - [ (assertion, Some (make_check_false ())) ] - | (true,true) -> proceed_with_assertion_3 [ ] - | (false,_) -> proceed_with_assertion_3 [ (assertion_2 (), None) ] + let assertion = assertion_3 () in + if warning then + rte_warn + fmt_warn_shift_assert1 + d_predicate_named assertion; + (assertion, Some Property_status.False_if_reachable)::lassert + | (true,true) -> lassert + | (false,_) -> (assertion_3 (), None)::lassert + end else + lassert + in + match problem_with_assertion_2 () with + | true, false -> + let assertion = assertion_2 () in + if warning then + rte_warn + fmt_warn_shift_assert2 + d_predicate_named assertion; + ( do not proceed with assertion 3: left operand is negative, + hence result is implementation defined anyway for left shift ) + [ assertion, Some Property_status.False_if_reachable ] + | true, true -> proceed_with_assertion_3 [ ] + | false, _ -> + proceed_with_assertion_3 [ assertion_2 (), None ] ( assertion for downcasting to a signed integer type ) @@ -1172,56 +1180,54 @@ cast_typ expr = let e_typ = Cil.typeOf expr in - match e_typ with - | TInt (_,_) -> - let szTo = bitsSizeOf cast_typ - and szFrom = bitsSizeOf e_typ - in - if (szTo < szFrom) then - ( downcast: the expression result should fit on szTo bits ) - let (minType,maxType) = (get_signed_min szTo, get_signed_max szTo) - in let term = translate_C_expr_to_term ~cast:false expr in - let assertion_le () = assertion_le term maxType - and assertion_ge () = assertion_ge term minType - in - let ceval = - if simplify_constants then ( - match get_expr_val expr with - | Some a64 -> ( constant expr ) - Some (Int64.compare a64 minType >= 0, - Int64.compare a64 maxType <= 0) - | None -> None - ) else None - in match ceval with - | None -> - let full_assertion () = - Logic_const.pand (assertion_le (), assertion_ge ()) - in [ (full_assertion (), None) ] - | Some (emin,emax) -> ( - match (emin,emax) with - | (true,true) -> [] - | (true,false) -> - let assertion = assertion_le () in - if warning then - rte_warn - "signed downcast assert broken: %a" - d_predicate_named assertion - ; - [ (assertion, Some (make_check_false ())) ] - | (false,true) -> - let assertion = assertion_ge () in - if warning then - rte_warn - "signed downcast assert broken: %a" - d_predicate_named assertion - ; - [ (assertion_le (), Some (make_check_false ())) ] - - | (false,false) -> assert false ( should not happen ) - - ) - else [] - | _ -> [] + match e_typ with + | TInt (_,_) -> + let szTo = bitsSizeOf cast_typ + and szFrom = bitsSizeOf e_typ + in + if (szTo < szFrom) then + ( downcast: the expression result should fit on szTo bits ) + let (minType,maxType) = + (min_signed_number szTo, max_signed_number szTo) + in + let term = translate_C_expr_to_term ~cast:false expr in + let assertion_le () = assertion_le term maxType in + let assertion_ge () = assertion_ge term minType in + let ceval = + if simplify_constants then ( + match get_expr_val expr with + | Some a64 -> ( constant expr ) + Some (My_bigint.ge a64 minType, + My_bigint.le a64 maxType) + | None -> None) + else None + in match ceval with + | None -> + let full_assertion () = + Logic_const.pand (assertion_le (), assertion_ge ()) + in + [ full_assertion (), None ] + | Some (emin,emax) -> ( + match (emin,emax) with + | (true,true) -> [] + | (true,false) -> + let assertion = assertion_le () in + if warning then + rte_warn + fmt_warn_signed_downcast_assert + d_predicate_named assertion ; + [ assertion, Some Property_status.False_if_reachable ] + | (false,true) -> + let assertion = assertion_ge () in + if warning then + rte_warn + fmt_warn_signed_downcast_assert + d_predicate_named assertion ; + [ assertion_le (), Some Property_status.False_if_reachable ] + + | (false,false) -> assert false ( should not happen )) + else [] + | _ -> [] ( assertion for preconditions ) type orig_lval = ( StartOfOrig | ) AddrOfOrig | LvalOrig @@ -1232,8 +1238,8 @@ match fa_terms with | [] -> None | (formal,term) :: tl -> - if vinfo.vid = formal.vid then Some term - else find_term_to_replace vinfo tl + if vinfo.vid = formal.vid then Some term + else find_term_to_replace vinfo tl exception AddrOfFormal exception NoResult @@ -1254,10 +1260,11 @@ | TConst _ | TSizeOf _ | TSizeOfStr _ | TAlignOf _ | Tnull | Ttype _ | Tempty_set -> SkipChildren - | TLval _tlv -> + | Tat _ -> self#add_tlval t ; SkipChildren - self#add_tlval t ; - DoChildren + | Tunion _ + | Tinter _ + | TLval _ -> self#add_tlval t ; DoChildren | _ -> DoChildren @@ -1266,7 +1273,6 @@ end - ( for each lval, replace each logic_variable which stems from a C variable by the term corresponding to the variable at this point iff it is a formal ) @@ -1274,98 +1280,97 @@ let treat_tlval fa_terms ret_opt origin tlval = let prefix_origin ntlval = match origin with - | LvalOrig -> TLval ntlval - | AddrOfOrig -> TAddrOf ntlval + | LvalOrig -> TLval ntlval + | AddrOfOrig -> TAddrOf ntlval in let (t_lhost, t_offset) = tlval in - match t_lhost with + match t_lhost with - | TMem _st -> DoChildren + | TMem _st -> DoChildren - | TResult _ty -> ( ( for post-conditions and assigns containing a \result ) - match ret_opt with - | None -> raise NoResult ( BTS 692 ) - | Some trm -> + | TResult _ty -> ( ( for post-conditions and assigns containing a \result ) + match ret_opt with + | None -> raise NoResult ( BTS 692 ) + | Some trm -> ( [VP] What happens if t_offset <> TNoOffset? ) - ChangeTo (prefix_origin trm) - ) + ChangeTo (prefix_origin trm) + ) - | TVar { lv_origin = Some vinfo } when vinfo.vformal -> - (match find_term_to_replace vinfo fa_terms with - | None -> DoChildren - ( ? can this happen ? is it correct ? ) - | Some nt -> - let make_li tmp_lvar = { - l_var_info = tmp_lvar; l_body = LBterm nt; - l_type = None; l_tparams = []; - l_labels = []; l_profile = []; - } - in - let make_tlet () = - let tmp_lvar = make_temp_logic_var nt.term_type in - Tlet - (make_li tmp_lvar, - mk_term - (prefix_origin (TVar tmp_lvar, t_offset)) - nt.term_type) - in - let tlet_or_ident () = - if t_offset = TNoOffset then + | TVar { lv_origin = Some vinfo } when vinfo.vformal -> + (match find_term_to_replace vinfo fa_terms with + | None -> DoChildren + ( ? can this happen ? is it correct ? ) + | Some nt -> + let make_li tmp_lvar = { + l_var_info = tmp_lvar; l_body = LBterm nt; + l_type = None; l_tparams = []; + l_labels = []; l_profile = []; + } + in + let make_tlet () = + let tmp_lvar = make_temp_logic_var nt.term_type in + Tlet + (make_li tmp_lvar, + mk_term + (prefix_origin (TVar tmp_lvar, t_offset)) + nt.term_type) + in + let tlet_or_ident () = + if t_offset = TNoOffset then ( Nothing to substitute afterwards. ) - ChangeTo nt.term_node - else + ChangeTo nt.term_node + else ( May need substitution in t_offset. ) - ChangeDoChildrenPost (make_tlet (), fun x -> x) - in - let add_offset lval = addTermOffsetLval t_offset lval in - match nt.term_node with - | TLval lv -> - ChangeDoChildrenPost - (prefix_origin (add_offset lv), fun x -> x) - | TStartOf lv -> - let lv = add_offset lv in - let t = - match origin with - LvalOrig -> TStartOf lv - | AddrOfOrig -> TAddrOf lv - in - ChangeDoChildrenPost(t,fun x->x) - ( [VP]: TAddrOf must be treated as the other - non-lval arguments. ) - (| TAddrOf (lhost,off) -> - let prefix_origin2 lv = - match nt.term_node with - | TLval _ -> TLval lv - | TStartOf _ -> TStartOf lv - | _ -> TAddrOf lv - in - ChangeDoChildrenPost - ((let ntlval = addTermOffsetLval t_offset (lhost,off) - in prefix_origin2 ntlval), fun x -> x) - ) - | TCastE(ty,{ term_node = TLval lv | TStartOf lv }) -> - (match origin with - LvalOrig -> tlet_or_ident() - | AddrOfOrig when t_offset = TNoOffset -> - let t = - Logic_const.taddrof lv (typeOfTermLval lv) - in - ChangeTo (TCastE(TPtr(ty,[]), t)) - | AddrOfOrig -> - let lh = TMem nt in - ChangeDoChildrenPost - (TAddrOf (lh,t_offset),fun x -> x)) - | _ when origin = AddrOfOrig -> - let source = Cil.source nt.term_loc in - rte_warn ~source - "Cannot substitute a non-lval \ + ChangeDoChildrenPost (make_tlet (), fun x -> x) + in + let add_offset lval = addTermOffsetLval t_offset lval in + match nt.term_node with + | TLval lv -> + ChangeDoChildrenPost + (prefix_origin (add_offset lv), fun x -> x) + | TStartOf lv -> + let lv = add_offset lv in + let t = + match origin with + LvalOrig -> TStartOf lv + | AddrOfOrig -> TAddrOf lv + in + ChangeDoChildrenPost(t,fun x->x) + ( [VP]: TAddrOf must be treated as the other + non-lval arguments. ) + (| TAddrOf (lhost,off) -> + let prefix_origin2 lv = + match nt.term_node with + | TLval _ -> TLval lv + | TStartOf _ -> TStartOf lv + | _ -> TAddrOf lv + in + ChangeDoChildrenPost + ((let ntlval = addTermOffsetLval t_offset (lhost,off) + in prefix_origin2 ntlval), fun x -> x) + ) + | TCastE(ty,{ term_node = TLval lv | TStartOf lv }) -> + (match origin with + LvalOrig -> tlet_or_ident() + | AddrOfOrig when t_offset = TNoOffset -> + let t = + Logic_const.taddrof lv (typeOfTermLval lv) + in + ChangeTo (TCastE(TPtr(ty,[]), t)) + | AddrOfOrig -> + let lh = TMem nt in + ChangeDoChildrenPost + (TAddrOf (lh,t_offset),fun x -> x)) + | _ when origin = AddrOfOrig -> + rte_warn ~source:(fst nt.term_loc) + "Cannot substitute a non-lval \ parameter under an addrof operation"; - raise AddrOfFormal - | _ -> tlet_or_ident ()) - | _ -> DoChildren + raise AddrOfFormal + | _ -> tlet_or_ident ()) + | _ -> DoChildren -let replacement_visitor fa_terms ret_opt = object +let replacement_visitor replace_pre fa_terms ret_opt = object ( for each term, replace each logic_variable which stems from a C variable by the term corresponding to the variable at this point iff it is a formal ) @@ -1385,14 +1390,22 @@ ) | _ -> DoChildren + method vlogic_label l = + match l with + | StmtLabel _ -> DoChildren + | LogicLabel _ + when Cil_datatype.Logic_label.equal l Logic_const.pre_label -> + ChangeDoChildrenPost(replace_pre, fun x->x) + | LogicLabel _ -> DoChildren + end -let treat_pred pred fa_terms (ret_opt : term_lval option) = - let visitor = replacement_visitor fa_terms ret_opt in +let treat_pred replace_pre pred fa_terms (ret_opt : term_lval option) = + let visitor = replacement_visitor replace_pre fa_terms ret_opt in visitCilPredicate (visitor :> cilVisitor) pred -let treat_term trm fa_terms ret_opt = - let visitor = replacement_visitor fa_terms ret_opt in +let treat_term replace_pre trm fa_terms ret_opt = + let visitor = replacement_visitor replace_pre fa_terms ret_opt in visitCilTerm (visitor :> cilVisitor) trm (* AST inplace visitor for runtime annotation generation ) @@ -1437,10 +1450,13 @@ module H = Hashtbl module HStmt = Cil_datatype.Stmt.Hashtbl +exception NontreatedAssign +exception DontKeep + class rte_annot_visitor kf = object(self) inherit Visitor.frama_c_inplace ( inplace since no Ast transformation: - only annotations are added ) + only annotations are added ) val mutable skip_set = SkipIdSet.empty val mutable index_behavior = 0 @@ -1481,86 +1497,73 @@ method private is_ConstFold () = Parameter_map.is_true ConstFold.name other_optionTbl - method private queue_stmt_spec _kf spec = + method private queue_stmt_spec spec = let stmt = Extlib.the (self#current_stmt) in + let kf = Extlib.the self#current_kf in Queue.add (fun () -> let annot = - Logic_const.new_code_annotation (AStmtSpec (stmt_)spec) + Logic_const.new_code_annotation (AStmtSpec ([],spec)) in - Annotations.add - stmt - [ precond_dep_state ] - (Db_types.Before (Db_types.User annot)) - ) self#get_filling_actions + Annotations.add kf stmt [ precond_dep_state ] (User annot)) + self#get_filling_actions - method private queue_assertion ?(pos = Before) assertion_list = - (* add an assertion (with an optionally given status) in front of current statement ) + method private queue_assertion assertion_list = + ( add an assertion (with an optionally given status) in front of current + statement ) match assertion_list with - | [] -> () - | _ -> - let stmt = Extlib.the (self#current_stmt) in - let kf = Extlib.the (self#current_kf) in - let already_posted_assertions = - try - HStmt.find assertion_table stmt - with Not_found -> [] - in let pruned_assertion_list = - ( do not keep an assertion if an equivalent assertion (content) - is already scheduled ) - List.rev ( - List.fold_left - (fun acc (assertion, status_opt) -> - if not (List.exists - (fun p -> - Logic_utils.is_same_predicate - p assertion.content) - already_posted_assertions) - then (assertion, status_opt) :: acc - else acc - ) [] assertion_list - ) - in let loc_add_assertion assertion assertion_status_opt = - let rte_named_assertion = - ( give a name to assertion in order to indicate - it has been generated by RTE plugin ) - { content = assertion.content ; - loc = assertion.loc ; name = [ rte_prefix ] } - in let annot = - Logic_const.new_code_annotation - (AAssert ([], rte_named_assertion)) - in - Annotations.add - stmt - [ rte_dep_state ] - (match pos with - | Before -> Db_types.Before (Db_types.User annot) - | After -> - Db_types.After (Db_types.User annot) ( not used )); - let astatus = match assertion_status_opt with - | None -> Unknown - | Some checked_status -> checked_status - in - let ip = Property.ip_of_code_annot kf stmt annot in - List.iter (fun x -> S.set x [] astatus) ip - in - ( update scheduled assertions ) - let () = HStmt.replace assertion_table stmt - (List.rev_append - (List.rev_map (fun (a,_) -> a.content) pruned_assertion_list) - already_posted_assertions) - in - Queue.add - (fun () -> - List.iter - (fun (assertion, assertion_status_opt) -> - loc_add_assertion assertion assertion_status_opt - ) pruned_assertion_list - ) self#get_filling_actions - - method private get_current_kf () = - Kernel_function.find_englobing_kf (Extlib.the (self#current_stmt)) + | [] -> () + | _ -> + let stmt = Extlib.the self#current_stmt in + let kf = Extlib.the self#current_kf in + let already_posted_assertions = + try + HStmt.find assertion_table stmt + with Not_found -> [] + in + let pruned_assertion_list = + ( do not keep an assertion if an equivalent assertion (content) + is already scheduled ) + List.rev + (List.fold_left + (fun acc (assertion, status_opt) -> + if not (List.exists + (fun p -> + Logic_utils.is_same_predicate + p assertion.content) + already_posted_assertions) + then (assertion, status_opt) :: acc + else acc) + [] + assertion_list) + in + let loc_add_assertion assertion assertion_status_opt = + let rte_named_assertion = + ( give a name to assertion in order to indicate + it has been generated by RTE plugin ) + { content = assertion.content ; + loc = assertion.loc ; name = [ rte_prefix ] } + in + let annot = + Logic_const.new_code_annotation (AAssert ([], rte_named_assertion)) + in + Annotations.add kf stmt [ rte_dep_state ] (User annot); + let ip = Property.ip_of_code_annot kf stmt annot in + List.iter(fun x -> emit_status x assertion_status_opt) ip + in + ( update scheduled assertions ) + HStmt.replace assertion_table stmt + (List.rev_append + (List.rev_map (fun (a,_) -> a.content) pruned_assertion_list) + already_posted_assertions); + Queue.add + (fun () -> + List.iter + (fun (assertion, assertion_status_opt) -> + loc_add_assertion assertion assertion_status_opt) + pruned_assertion_list) + self#get_filling_actions method private mk_new_behavior_name kf_callee = let error () = @@ -1568,206 +1571,253 @@ error "Generated too many behavior names." ; assert false in - let kf = self#get_current_kf () ( get englobing kf ) + let kf = Extlib.the self#current_kf ( get englobing kf ) in let known_behaviors = Kernel_function.all_function_behaviors kf - in let rec aux_new_name i = - let name = - precond_prefix ^ "_" ^ - (Kernel_function.get_name kf_callee) ^ "_" ^ (string_of_int i) - in if List.mem name known_behaviors then ( - let nindex = i + 1 - in if nindex = 0 then error () + in let rec aux_new_name i = + ( [JS 20110607] seem to be equivalent to + Kernel_function.fresh_behavior_name ) + let name = + precond_prefix ^ "_" ^ + (Kernel_function.get_name kf_callee) ^ "_" ^ (string_of_int i) + in if List.mem name known_behaviors then ( + let nindex = i + 1 + in if nindex = 0 then error () ( if index becomes 0 (again): serious problem, but unlikely to happen ) - else aux_new_name nindex - ) else (name, i) - in - let (name, new_index) = - try - let i = H.find bhv_index_table kf - in - let nindex = i+1 - in if nindex = 0 then error () - else aux_new_name nindex - with Not_found -> - aux_new_name 0 - in - H.replace bhv_index_table kf new_index ; - name + else aux_new_name nindex + ) else (name, i) + in + let (name, new_index) = + try + let i = H.find bhv_index_table kf + in + let nindex = i+1 + in if nindex = 0 then error () + else aux_new_name nindex + with Not_found -> + aux_new_name 0 + in + H.replace bhv_index_table kf new_index ; + name method private make_stmt_contract kf formals_actuals_terms ret_opt = - let tret_opt = - match ret_opt with - | None -> None - | Some lv -> Some (Logic_utils.lval_to_term_lval ~cast:true lv) + let tret_opt = match ret_opt with + | None -> None + | Some lv -> Some (Logic_utils.lval_to_term_lval ~cast:true lv) in - let fun_transform_pred p = + let fun_transform_pred replace_pre p = let p' = Logic_const.pred_of_id_pred p in try let p_unnamed = Logic_const.unamed (treat_pred + replace_pre p'.content formals_actuals_terms tret_opt) in Logic_const.new_predicate { content = p_unnamed.content ; loc = p_unnamed.loc ; - name = p'.name - } + name = p'.name } with - | AddrOfFormal - | NoResult -> - ( A warning has been emitted, we simply ignore the predicate here. ) - Logic_const.new_predicate Logic_const.ptrue + | AddrOfFormal + | NoResult -> + ( A warning has been emitted, we simply ignore the predicate here. ) + Logic_const.new_predicate Logic_const.ptrue and fun_transform_assigns assigns = ( substitute terms, then for each from extract lvals and - keep those and only those as froms ) + keep those and only those as froms ) let treat_from it = + let rec keep_it t = + match t.term_node with + | TLval _ -> true + | Tat (loc,_) -> keep_it loc + | TCastE (_,te) -> keep_it te + | Tinter locs + | Tunion locs -> ( + try + List.iter + (fun loc -> + if not(keep_it loc) then + raise DontKeep + ) locs ; + true + with DontKeep -> false ) + | _ -> false + in + (* also, discard casts in froms ) + let rec transform_term t = + match t.term_node with + | TCastE (_,te) -> transform_term te + | _ -> t + in let nterm = - treat_term it.it_content formals_actuals_terms tret_opt + treat_term Logic_const.old_label + it.it_content formals_actuals_terms tret_opt in - let visitor = tlval_fetcher_visitor () in - let _ = visitCilTerm (visitor :> cilVisitor) nterm in + if keep_it nterm then + [ Logic_const.new_identified_term (transform_term nterm) ] + else [] + ( Do not generate froms from child left values any more ) + ( + let visitor = tlval_fetcher_visitor () in + let _ = visitCilTerm (visitor :> cilVisitor) nterm in let list_tlvals = visitor#fetch_lvals () in - List.map - (fun lv -> Logic_const.new_identified_term lv) list_tlvals + List.rev_map + (fun lv -> + Logic_const.new_identified_term lv) + (List.filter keep_it list_tlvals) + ) in let treat_identified_term_zone_froms z = match z with - | FromAny -> FromAny - | From l -> From (List.flatten (List.map treat_from l)) + | FromAny -> FromAny + | From l -> + From (List.flatten (List.rev_map treat_from l)) in let treat_assign (z,lz) = - let nt = - treat_term - z.it_content formals_actuals_terms tret_opt ( should be an lval ) - in - match nt.term_node with - | TLval _ -> ( if substituted term is not an lval, - do not generate an assign ) - Some (Logic_const.new_identified_term nt, - treat_identified_term_zone_froms lz) - | _ -> None - in - let treat_assigns_list acc a = try - match treat_assign a with - | None -> acc - | Some e -> e :: acc - with - | AddrOfFormal - | NoResult -> acc - ( Ignore the location based on the address of a formal parameter. ) - + let nt = + treat_term Logic_const.old_label + z.it_content formals_actuals_terms tret_opt + ( should be an lval ) + in + ( also treat union, inter and at terms ) + match nt.term_node with + | Tat _ + | TLval _ + | Tunion _ + | Tinter _ -> + (Logic_const.new_identified_term nt, + treat_identified_term_zone_froms lz) + | _ -> raise NontreatedAssign + with + | AddrOfFormal + | NoResult -> raise NontreatedAssign in let treat_assigns_clause l = ( compute list of assigns as (terms, list of terms) ; if empty list of terms => it's a Nothing, else Location ... ) ( then process to transform assign on \result ) match l with - WritesAny -> WritesAny - | Writes l -> Writes (List.fold_left treat_assigns_list [] l) + | WritesAny -> WritesAny + | Writes l -> + try + Writes (List.rev (List.rev_map treat_assign l)) + with NontreatedAssign -> WritesAny in let final_assigns_list = match ret_opt with - | None -> - ( no return value: there should be no assign of \result ) - treat_assigns_clause assigns - | Some ret -> - let ret_type = typeOfLval ret in - let nlist_assigns = - ( if there is a assigns \at(\result,Post) \from x - replace by \assigns \result \from x ) - match assigns with - | WritesAny -> WritesAny - | Writes assigns -> - let rec change_at_result acc assgn = - match assgn with - [] -> Writes (List.rev acc) - | (a,from)::tl -> - let new_a = - match a.it_content.term_node with - | Tat ({term_node=(TLval(TResult _,_) as trm)}, - LogicLabel (_, "Post")) -> - let ttype = Ctype ret_type - ( cf. bug #559 ) - ( Logic_utils.typ_to_logic_type - ret_type ) - in - Logic_const.new_identified_term - (mk_term trm ttype) - | _ -> a - in - change_at_result ((new_a,from) :: acc) tl - in - change_at_result [] assigns - in - ( add assign on result iff no assigns(\result) already appears ; - treat_assign will then do the job ) - let add_assigns_result () = - ( add assigns \result with empty list of froms to do the job ) - let ttype = Ctype ret_type - ( bug #559 ) - ( Logic_utils.typ_to_logic_type ret_type ) - in - let nterm = mk_term (TLval (TResult ret_type, TNoOffset)) ttype in - (Logic_const.new_identified_term nterm, FromAny) - in - match nlist_assigns with - WritesAny -> WritesAny - | Writes l when - List.exists - (fun (a,_) -> Logic_utils.is_result a.it_content) l - -> - nlist_assigns - | Writes l -> Writes (add_assigns_result()::l) - in treat_assigns_clause final_assigns_list + | None -> + ( no return value: there should be no assign of \result ) + assigns + | Some ret -> + let ret_type = typeOfLval ret in + let nlist_assigns = + ( if there is a assigns \at(\result,Post) \from x + replace by assigns \result \from x ) + match assigns with + | WritesAny -> WritesAny + | Writes assigns -> + let rec change_at_result acc assgn = + match assgn with + [] -> Writes (List.rev acc) + | (a,from)::tl -> + let new_a = + match a.it_content.term_node with + | Tat ({term_node=(TLval(TResult _,_) as trm)}, + LogicLabel (_, "Post")) -> + let ttype = Ctype ret_type + ( cf. bug #559 ) + ( Logic_utils.typ_to_logic_type + ret_type ) + in + Logic_const.new_identified_term + (mk_term trm ttype) + | _ -> a + in + change_at_result ((new_a,from) :: acc) tl + in + change_at_result [] assigns + in + ( add assign on result iff no assigns(\result) already appears ; + treat_assign will then do the job ) + let add_assigns_result () = + ( add assigns \result with empty list of froms to do the job ) + let ttype = Ctype ret_type + ( bug #559 ) + ( Logic_utils.typ_to_logic_type ret_type ) + in + let nterm = mk_term (TLval (TResult ret_type, TNoOffset)) ttype in + (Logic_const.new_identified_term nterm, FromAny) + in + match nlist_assigns with + | WritesAny -> WritesAny + | Writes l when + List.exists + (fun (a,_) -> Logic_utils.is_result a.it_content) l + -> + nlist_assigns + | Writes l -> Writes (add_assigns_result()::l) + in + treat_assigns_clause final_assigns_list and behaviors = ( calling get_spec on a function with a contract but no code generates default assigns ) (Kernel_function.get_spec kf).spec_behavior in - try - let new_behaviors = - List.fold_left - (fun acc bhv -> - (mk_behavior - ~name:(self#mk_new_behavior_name kf) - ~post_cond:(List.map - (fun (k,p) -> (k,fun_transform_pred p)) bhv.b_post_cond) - ~assumes:(List.map fun_transform_pred bhv.b_assumes) - ~requires:(List.map fun_transform_pred bhv.b_requires) - ~assigns:(fun_transform_assigns bhv.b_assigns) - ~extended:[] ())::acc - ) [] behaviors - in - if new_behaviors <> [] then - let spec = { spec_behavior = List.rev new_behaviors ; - spec_variant = None ; - spec_terminates = None ; - spec_complete_behaviors = [] ; - spec_disjoint_behaviors = [] - } - in Some spec - else None - with Exit -> None + try + let new_behaviors = + List.fold_left + (fun acc bhv -> + let b = + mk_behavior + ~name:(self#mk_new_behavior_name kf) + ~post_cond:(List.map + (fun (k,p) -> k, + fun_transform_pred Logic_const.old_label p) + bhv.b_post_cond) + ~assumes:(List.map + (fun_transform_pred Logic_const.here_label) + bhv.b_assumes) + ~requires:(List.map + (fun_transform_pred Logic_const.here_label) + bhv.b_requires) + ~assigns:(fun_transform_assigns bhv.b_assigns) + ~extended:[] + () + in + b :: acc) + [] + behaviors + in + (match new_behaviors with + | [] -> None + | _ :: _ -> + Some + { spec_behavior = List.rev new_behaviors ; + spec_variant = None ; + spec_terminates = None ; + spec_complete_behaviors = [] ; + spec_disjoint_behaviors = [] }) + with Exit -> None method vinst vi = ( assigned left values are checked for valid access ) match vi with - | Set (lval,_,_) -> - if self#is_DoMemAccess () then - self#queue_assertion (get_lval_assertion lval) - ; + | Set (lval,_,_) -> + if self#is_DoMemAccess () then + self#queue_assertion (get_lval_assertion lval) + ; + DoChildren + | Call (ret_opt,funcexp,argl,_) -> ( + if not(self#is_DoCalledPrecond ()) then DoChildren - | Call (ret_opt,funcexp,argl,_) -> ( - if not(self#is_DoCalledPrecond ()) then - DoChildren - else - match funcexp.enode with - | Lval (Var vinfo,NoOffset) -> - let kf = Globals.Functions.get vinfo in - let formals = Kernel_function.get_formals kf in + else + match funcexp.enode with + | Lval (Var vinfo,NoOffset) -> + let kf = Globals.Functions.get vinfo in + let do_no_implicit_cast () = + let formals = Kernel_function.get_formals kf in if (List.length formals <> List.length argl) then ( rte_warn "(%a) function call with # actuals <> # formals: not treated" @@ -1778,189 +1828,220 @@ let formals_actuals_terms = List.rev_map2 (fun formal arg_exp -> - (formal, - Logic_utils.expr_to_term ~cast:true arg_exp) + (formal, + Logic_utils.expr_to_term ~cast:true arg_exp) ) formals argl in - match self#make_stmt_contract kf formals_actuals_terms ret_opt with - | None -> DoChildren - | Some contract_stmt -> - self#queue_stmt_spec kf contract_stmt - ; - DoChildren + match self#make_stmt_contract kf formals_actuals_terms ret_opt with + | None -> DoChildren + | Some contract_stmt -> + self#queue_stmt_spec contract_stmt + ; + DoChildren ) - | Lval (Mem _,NoOffset) -> - rte_warn "(%a) function called through a pointer: not treated" - d_stmt (Extlib.the (self#current_stmt)) - ; - DoChildren - | _ -> assert false - ) - | _ -> DoChildren + in ( + match ret_opt with + | None -> do_no_implicit_cast () + | Some lv -> + let kf_ret_type = Kernel_function.get_return_type kf + and lv_type = Cil.typeOfLval lv in + if Cil.need_cast kf_ret_type lv_type then ( + rte_warn "(%a) function call with intermediate cast: not treated" + d_stmt (Extlib.the (self#current_stmt)) + ; + DoChildren + ) + else do_no_implicit_cast () + ) + | Lval (Mem _,NoOffset) -> + rte_warn "(%a) function called through a pointer: not treated" + d_stmt (Extlib.the (self#current_stmt)) + ; + DoChildren + | _ -> assert false + ) + | _ -> DoChildren method vexpr exp = debug "considering exp %a\n" Cil.d_exp exp ; match exp.enode with - | BinOp((Div|Mod) as op,dividend,divisor,TInt(kind,_)) -> - ( add assertion "divisor not zero" ) - if self#is_DoDivMod () then + | BinOp((Div|Mod) as op,dividend,divisor,TInt(kind,_)) -> + ( add assertion "divisor not zero" ) + if self#is_DoDivMod () then + self#queue_assertion + (get_divmod_assertion + ~simplify_constants:(self#is_ConstFold ()) + ~warning:(self#is_Warning ()) + divisor) + ; + if (self#is_DoSignedOverflow ()) && (op = Div) && (isSigned kind) then + begin + ( treat the special case of signed division overflow + (no signed modulo overflow) ) self#queue_assertion - (get_divmod_assertion + (get_signed_div_assertion ~simplify_constants:(self#is_ConstFold ()) ~warning:(self#is_Warning ()) - divisor) - ; - if (self#is_DoSignedOverflow ()) && (op = Div) && (isSigned kind) then - begin - ( treat the special case of signed division overflow - (no signed modulo overflow) ) - self#queue_assertion - (get_signed_div_assertion - ~simplify_constants:(self#is_ConstFold ()) - ~warning:(self#is_Warning ()) - dividend divisor) - - end - ; - DoChildren + dividend divisor) + end + ; + DoChildren - | BinOp((Shiftlt|Shiftrt) as shiftop,loperand,roperand,TInt(kind,_)) -> + | BinOp((Shiftlt|Shiftrt) as shiftop,loperand,roperand,TInt(kind,_)) -> - if self#is_DoSignedOverflow () || self#is_DoUnsignedOverflow () then ( - let (a, isOk) = - ( generate and check assertion on right operand of shift ) - get_bitwise_shift_right_operand_assertion - ~simplify_constants:(self#is_ConstFold ()) - ~warning:(self#is_Warning ()) - exp roperand - in - self#queue_assertion a ; - if isOk ( right operand is correct: - otherwise no need to proceed with other assertions ) - then - ( - ( assertions specific to signed shift ) - if (self#is_DoSignedOverflow ()) && (isSigned kind) then ( + if self#is_DoSignedOverflow () || self#is_DoUnsignedOverflow () then ( + let (a, isOk) = + ( generate and check assertion on right operand of shift ) + get_bitwise_shift_right_operand_assertion + ~simplify_constants:(self#is_ConstFold ()) + ~warning:(self#is_Warning ()) + exp roperand + in + self#queue_assertion a ; + if isOk ( right operand is correct: + otherwise no need to proceed with other assertions ) + then + ( + ( assertions specific to signed shift ) + if (self#is_DoSignedOverflow ()) && (isSigned kind) then ( + self#queue_assertion + (get_bitwise_shift_assertion + ~simplify_constants:(self#is_ConstFold ()) + ~warning:(self#is_Warning ()) + exp shiftop loperand roperand) + ) + ; + ( assertions specific to unsigned shift ) + if self#is_DoUnsignedOverflow () && + (shiftop = Shiftlt) && not(isSigned kind) then ( self#queue_assertion - (get_bitwise_shift_assertion + (get_bitwise_lshift_unsigned_assertion ~simplify_constants:(self#is_ConstFold ()) ~warning:(self#is_Warning ()) - exp shiftop loperand roperand) - ) - ; - - ( assertions specific to unsigned shift ) - if self#is_DoUnsignedOverflow () && - (shiftop = Shiftlt) && not(isSigned kind) then ( - self#queue_assertion - (get_bitwise_lshift_unsigned_assertion - ~simplify_constants:(self#is_ConstFold ()) - ~warning:(self#is_Warning ()) - exp loperand roperand) - ) - ) - ) - ; - DoChildren - - | BinOp((PlusA|MinusA|Mult) - as op,loperand,roperand,TInt(kind,_)) when (isSigned kind) -> - ( may be skipped if enclosing expression is a downcast to a signed type ) - if (self#is_DoSignedOverflow ()) && - not(self#is_in_skip_set exp.eid SkipBounding) then - self#queue_assertion - (get_multsubadd_assertion - ~simplify_constants:(self#is_ConstFold ()) - ~warning:(self#is_Warning ()) - exp op loperand roperand) - ; - DoChildren - - | BinOp((PlusA|MinusA|Mult) - as op,loperand,roperand,TInt(kind,_)) when not(isSigned kind) -> - if self#is_DoUnsignedOverflow () then - self#queue_assertion - (get_multsubadd_unsigned_assertion - ~simplify_constants:(self#is_ConstFold ()) - ~warning:(self#is_Warning ()) - exp op loperand roperand) - ; - DoChildren + exp loperand roperand) + ) + ) + ) + ; + DoChildren - | UnOp(Neg,operand,TInt(kind,_)) when (isSigned kind) -> - if self#is_DoSignedOverflow () then - self#queue_assertion - (get_uminus_assertion - ~simplify_constants:(self#is_ConstFold ()) - ~warning:(self#is_Warning ()) - operand) - ; - DoChildren + | BinOp((PlusA|MinusA|Mult) + as op,loperand,roperand,TInt(kind,_)) when (isSigned kind) -> + ( may be skipped if enclosing expression is a downcast to a signed type ) + if (self#is_DoSignedOverflow ()) && + not(self#is_in_skip_set exp.eid SkipBounding) then + self#queue_assertion + (get_multsubadd_assertion + ~simplify_constants:(self#is_ConstFold ()) + ~warning:(self#is_Warning ()) + exp op loperand roperand) + ; + DoChildren + | BinOp((PlusA|MinusA|Mult) + as op,loperand,roperand,TInt(kind,_)) when not(isSigned kind) -> + if self#is_DoUnsignedOverflow () then + self#queue_assertion + (get_multsubadd_unsigned_assertion + ~simplify_constants:(self#is_ConstFold ()) + ~warning:(self#is_Warning ()) + exp op loperand roperand) + ; + DoChildren - ( Note: if unary minus on unsigned integer is to be understood as - "subtracting the promoted value from the largest value - of the promoted type and adding one" - the result is always representable so no overflow - ) - - | Lval lval -> - ( left values are checked for valid access ) - if self#is_DoMemAccess () then ( - debug "exp %a is an lval: validity of potential mem access checked\n" - Cil.d_exp exp ; - self#queue_assertion (get_lval_assertion lval) - ) - ; - DoChildren + | UnOp(Neg,operand,TInt(kind,_)) when (isSigned kind) -> + if self#is_DoSignedOverflow () then + self#queue_assertion + (get_uminus_assertion + ~simplify_constants:(self#is_ConstFold ()) + ~warning:(self#is_Warning ()) + operand) + ; + DoChildren - | CastE (TInt (kind,_) as typ, e) when (isSigned kind) -> - if self#is_DoDownCast () then ( - let downcast_asserts = - get_downcast_assertion - ~simplify_constants:(self#is_ConstFold ()) - ~warning:(self#is_Warning ()) - typ e - in match downcast_asserts with - | [] -> () - | _ -> - self#queue_assertion downcast_asserts - ; - self#add_to_skip_set e.eid SkipBounding - ( expression should be skipped w.r.t - signed mult/add/sub arithmetic overflow ) - ) - ; - DoChildren + ( Note: if unary minus on unsigned integer is to be understood as + "subtracting the promoted value from the largest value + of the promoted type and adding one" + the result is always representable so no overflow + ) + + | Lval lval -> + ( left values are checked for valid access ) + if self#is_DoMemAccess () then ( + debug "exp %a is an lval: validity of potential mem access checked\n" + Cil.d_exp exp ; + self#queue_assertion (get_lval_assertion lval) + ) + ; + DoChildren + | CastE (TInt (kind,_) as typ, e) when (isSigned kind) -> + if self#is_DoDownCast () then ( + let downcast_asserts = + get_downcast_assertion + ~simplify_constants:(self#is_ConstFold ()) + ~warning:(self#is_Warning ()) + typ e + in match downcast_asserts with + | [] -> () + | _ -> + self#queue_assertion downcast_asserts + ; + self#add_to_skip_set e.eid SkipBounding + ( expression should be skipped w.r.t + signed mult/add/sub arithmetic overflow ) + ) + ; + DoChildren + ( removed, see BTS#567: no point in asserting validity + of first cell of an array simply because its address + is taken as &tab[0] ) + ( | StartOf _lval -> - if self#is_DoMemAccess () then - self#queue_assertion - [ (Logic_const.pvalid (translate_C_expr_to_term ~cast:false exp), None) ] - ; - DoChildren - - | AddrOf _ - | Info _ - | UnOp _ - | Const _ - | CastE _ - | BinOp _ -> DoChildren - - - | SizeOf _ - | SizeOfE _ - | SizeOfStr _ - | AlignOf _ - | AlignOfE _ -> SkipChildren + if self#is_DoMemAccess () then + self#queue_assertion + [ (Logic_const.pvalid (translate_C_expr_to_term ~cast:false exp), None) ] + ; + DoChildren + ) + | StartOf _ + | AddrOf _ + | Info _ + | UnOp _ + | Const _ + | CastE _ + | BinOp _ -> DoChildren + + + | SizeOf _ + | SizeOfE _ + | SizeOfStr _ + | AlignOf _ + | AlignOfE _ -> SkipChildren end let remove_annotations_kf kf = + ( [JS 2011/08/04] fix bug #910: + new implementation now requires to remove by hand annotations. ) + let annotations = Kernel_function.code_annotations kf in + let must_keep _ state _ = match state with + | None -> true + | Some s -> + not (State.equal s (RteAnnotTbl.get_state kf) + || State.equal s (PrecondAnnotTbl.get_state kf)) + in + List.iter + (fun (stmt, _) -> + ( [false] because [Project.clear] is still applied ) + Annotations.filter ~reset:false must_keep kf stmt) + annotations; + ( JS: still keep [Project.clear] because I don't know if it clears something + else than annotations. If it is not the case, it can safely be removed ) ( remove annotations dependant on function (in fact all dependencies) let s = RteGlobalTbl.get_state kf in - Project.clear ~selection:(State_selection.Dynamic.only_dependencies s) () + Project.clear ~selection:(State_selection.Dynamic.only_dependencies s) () let is_computed_kf kf = ( check whether annotations are computed for function kf @@ -1968,20 +2049,20 @@ match kf.fundec with | Declaration _ -> true | Definition _ -> - (* check whether options have changed for function kf ) - let old_gen_opts = StateManager.find_current_gen_options kf - and new_gen_opts = Parameter_map.gen_from_command_line_options () - and old_other_opts = StateManager.find_current_other_options kf - and new_other_opts = Parameter_map.other_from_command_line_options () - in - ( case 1: generating options have changed ) - Parameter_map.compare old_gen_opts new_gen_opts <> 0 - || - ( case 2: no generating option has changed, but the user wants to - generate the same annotations with const folding, warning - enabled ... ) - (Parameter_map.is_one_true ~except:None new_gen_opts && - Parameter_map.compare old_other_opts new_other_opts <> 0) + ( check whether options have changed for function kf ) + let old_gen_opts = StateManager.find_current_gen_options kf + and new_gen_opts = Parameter_map.gen_from_command_line_options () + and old_other_opts = StateManager.find_current_other_options kf + and new_other_opts = Parameter_map.other_from_command_line_options () + in + ( case 1: generating options have changed ) + Parameter_map.compare old_gen_opts new_gen_opts <> 0 + || + ( case 2: no generating option has changed, but the user wants to + generate the same annotations with const folding, warning + enabled ... ) + (Parameter_map.is_one_true ~except:None new_gen_opts && + Parameter_map.compare old_other_opts new_other_opts <> 0) let annotate_kf_with kf new_gen_opts new_other_opts = ( generates annotation for function kf @@ -1993,11 +2074,11 @@ match kf.fundec with | Declaration _ -> () | Definition (f,_) -> - remove_annotations_kf kf ; - let vis = new rte_annot_visitor kf - (* (StateManager.find_current_gen_options kf) ) - in let _nkf = Visitor.visitFramacFunction vis f in - assert(_nkf == f) + remove_annotations_kf kf ; + let vis = new rte_annot_visitor kf + ( (StateManager.find_current_gen_options kf) ) + in let _nkf = Visitor.visitFramacFunction vis f in + assert(_nkf == f) in let old_gen_opts = StateManager.find_current_gen_options kf and old_other_opts = StateManager.find_current_other_options kf @@ -2006,36 +2087,36 @@ ( case 1: generating options have changed ) Parameter_map.compare old_gen_opts new_gen_opts <> 0 || - ( case 2: no generating option has changed, - but the user wants to generate the same annotations with const - folding, warning enabled ... ) - (Parameter_map.is_one_true ~except:None new_gen_opts && - Parameter_map.compare old_other_opts new_other_opts <> 0) + ( case 2: no generating option has changed, + but the user wants to generate the same annotations with const + folding, warning enabled ... ) + (Parameter_map.is_one_true ~except:None new_gen_opts && + Parameter_map.compare old_other_opts new_other_opts <> 0) then begin ( options have changed for function kf: there is some work to do ) debug "Options have changed: something to do for function %s" - (Kernel_function.get_name kf) ; + (Kernel_function.get_name kf) ; ( update analysis options for function kf ) StateManager.FuncOptionTbl.replace kf (new_gen_opts, new_other_opts) ; if Parameter_map.is_one_true ~except:None new_gen_opts then begin - ( there may be new annotations to add and remove ) - feedback "annotating function %s" (Kernel_function.get_name kf) ; - do_annotate_kf kf ; - ( set status of rte/precond generation (see properties_status.mli) ) - List.iter - (fun (opt_name, _opt_get, _, property_set) -> - property_set kf (Parameter_map.is_true opt_name new_gen_opts)) - Parameter_map.generating_opts + ( there may be new annotations to add and remove ) + feedback "annotating function %s" (Kernel_function.get_name kf) ; + do_annotate_kf kf ; + ( set status of rte/precond generation (see properties_status.mli) ) + List.iter + (fun (opt_name, _opt_get, _, property_set) -> + property_set kf (Parameter_map.is_true opt_name new_gen_opts)) + Parameter_map.generating_opts end else begin - ( all annotations should be removed ) - ( and RTE_Generated / Called_Precond_Generated are reset ) - feedback "unannotating function %s" (Kernel_function.get_name kf) ; - ( reset status of rte/precond generation ) - List.iter - (fun (_opt_name, _opt_get, _, property_set) -> - property_set kf false) - Parameter_map.generating_opts; - remove_annotations_kf kf + ( all annotations should be removed ) + ( and RTE_Generated / Called_Precond_Generated are reset ) + feedback "unannotating function %s" (Kernel_function.get_name kf) ; + ( reset status of rte/precond generation ) + List.iter + (fun (_opt_name, _opt_get, _, property_set) -> + property_set kf false) + Parameter_map.generating_opts; + remove_annotations_kf kf end end @@ -2062,8 +2143,8 @@ | Definition _ -> ( check whether options have changed for function kf ) annotate_kf_with kf - (Parameter_map.gen_from_command_line_options ()) - (Parameter_map.other_from_command_line_options ()) + (Parameter_map.gen_from_command_line_options ()) + (Parameter_map.other_from_command_line_options ()) let is_computed () = ( check whether annotations are computed for the @@ -2075,20 +2156,20 @@ let fsel = FunctionSelection.get () in Datatype.String.Set.is_empty fsel || let name = Kernel_function.get_name kf in - Datatype.String.Set.mem name fsel + Datatype.String.Set.mem name fsel in try - Globals.Functions.iter - (fun kf -> - if include_function kf then - begin - match kf.fundec with - | Declaration _ -> () - | Definition _ -> if not(is_computed_kf kf) then raise Exit - end - ) - ; - true + Globals.Functions.iter + (fun kf -> + if include_function kf then + begin + match kf.fundec with + | Declaration _ -> () + | Definition _ -> if not(is_computed_kf kf) then raise Exit + end + ) + ; + true with Exit -> false let compute () = @@ -2103,9 +2184,9 @@ Globals.Functions.iter (fun kf -> if include_function kf then begin - match kf.fundec with - | Declaration _ -> () - | Definition _ -> !Db.RteGen.annotate_kf kf + match kf.fundec with + | Declaration _ -> () + | Definition _ -> !Db.RteGen.annotate_kf kf end) let () = @@ -2159,7 +2240,7 @@ (* let do_precond = Dynamic.register - ~plugin:"rte" + ~plugin:"RteGen" "do_precond" (Datatype.func Kernel_function.ty @@ -2205,22 +2286,22 @@ module M6 = RTE_UnsignedOverflow_Generated let get_all_status () = - [ (M1.self, M1.get_state, M1.get); - (M2.self, M2.get_state, M2.get); - (M3.self, M3.get_state, M3.get); - (M4.self, M4.get_state, M4.get); - (M5.self, M5.get_state, M5.get); - (M6.self, M6.get_state, M6.get); + [ (M1.self, M1.get_state, M1.get, M1.set); + (M2.self, M2.get_state, M2.get, M2.set); + (M3.self, M3.get_state, M3.get, M3.set); + (M4.self, M4.get_state, M4.get, M4.set); + (M5.self, M5.get_state, M5.get, M5.set); + (M6.self, M6.get_state, M6.get, M6.set); ] let () = Db.register - Db.Journalization_not_required + Db.Journalization_not_required Db.RteGen.get_all_status get_all_status let get_precond_status () = - (M5.self, M5.get_state, M5.get) + (M5.self, M5.get_state, M5.get, M5.set) let () = Db.register @@ -2229,16 +2310,16 @@ get_precond_status let get_signedOv_status () = - (M1.self, M1.get_state, M1.get) + (M1.self, M1.get_state, M1.get, M1.set) let () = Db.register - Db.Journalization_not_required + Db.Journalization_not_required Db.RteGen.get_signedOv_status get_signedOv_status let get_divMod_status () = - (M3.self, M3.get_state, M3.get) + (M3.self, M3.get_state, M3.get, M3.set) let () = Db.register @@ -2247,25 +2328,25 @@ get_divMod_status let get_downCast_status () = - (M4.self, M4.get_state, M4.get) + (M4.self, M4.get_state, M4.get, M4.set) let () = Db.register - Db.Journalization_not_required + Db.Journalization_not_required Db.RteGen.get_downCast_status get_downCast_status let get_memAccess_status () = - (M2.self, M2.get_state, M2.get) + (M2.self, M2.get_state, M2.get, M2.set) let () = Db.register - Db.Journalization_not_required + Db.Journalization_not_required Db.RteGen.get_memAccess_status get_memAccess_status let get_unsignedOv_status () = - (M6.self, M6.get_state, M6.get) + (M6.self, M6.get_state, M6.get, M6.set) let () = Db.register @@ -2279,7 +2360,7 @@ (* all rte + precond ) let get_global_state = Dynamic.register - ~plugin:"rte" + ~plugin:"RteGen" "get_global_state" (Datatype.func Kernel_function.ty @@ -2290,7 +2371,7 @@ ( only rte (no precond) ) let get_rte_state = Dynamic.register - ~plugin:"rte" + ~plugin:"RteGen" "get_rte_state" (Datatype.func Kernel_function.ty @@ -2301,7 +2382,7 @@ ( only precond (no rte) ) let get_precond_state = Dynamic.register - ~plugin:"rte" + ~plugin:"RteGen" "get_precond_state" (Datatype.func Kernel_function.ty diff -Nru frama-c-20110201+carbon+dfsg/src/rte/rte_parameters.ml frama-c-20111001+nitrogen+dfsg/src/rte/rte_parameters.ml --- frama-c-20110201+carbon+dfsg/src/rte/rte_parameters.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/rte/rte_parameters.ml 2011-10-10 08:38:22.000000000 +0000 @@ -53,6 +53,7 @@ end) ( if DoAll is true: all other options become true, except for DoUnsignedOverflow + and "PreConds" <=> all "true" runtime error assertions are generated ) module DoAll = True @@ -107,9 +108,9 @@ (struct let option_name = "-rte-const" let help = "when on (by default), simplify assertions involving constants" - ( if on, evaluates constants in order to check if assertions - are trivially true / false ) - let kind = `Correctness + ( if on, evaluates constants in order to check if assertions + are trivially true / false ) + let kind = `Tuning end) module DoCalledPrecond = @@ -136,3 +137,9 @@ let help = "select <fun> for analysis (default all functions)" let kind = `Correctness end) + +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/rte/rte_parameters.mli frama-c-20111001+nitrogen+dfsg/src/rte/rte_parameters.mli --- frama-c-20110201+carbon+dfsg/src/rte/rte_parameters.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/rte/rte_parameters.mli 2011-10-10 08:38:22.000000000 +0000 @@ -22,26 +22,32 @@ include Plugin.S -module Enabled: Plugin.BOOL +module Enabled: Plugin.Bool -module DoUnsignedOverflow : Plugin.BOOL +module DoUnsignedOverflow : Plugin.Bool -module DoAll: Plugin.BOOL +module DoAll: Plugin.Bool -module Print: Plugin.BOOL +module Print: Plugin.Bool -module DoSignedOverflow : Plugin.BOOL +module DoSignedOverflow : Plugin.Bool -module DoDownCast : Plugin.BOOL +module DoDownCast : Plugin.Bool -module DoDivMod : Plugin.BOOL +module DoDivMod : Plugin.Bool -module DoMemAccess : Plugin.BOOL +module DoMemAccess : Plugin.Bool -module ConstFold : Plugin.BOOL +module ConstFold : Plugin.Bool -module Warn : Plugin.BOOL +module Warn : Plugin.Bool -module DoCalledPrecond : Plugin.BOOL +module DoCalledPrecond : Plugin.Bool -module FunctionSelection : Plugin.STRING_SET +module FunctionSelection : Plugin.String_set + +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/scope/datascope.ml frama-c-20111001+nitrogen+dfsg/src/scope/datascope.ml --- frama-c-20110201+carbon+dfsg/src/scope/datascope.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/scope/datascope.ml 2011-10-10 08:38:30.000000000 +0000 @@ -26,11 +26,9 @@ has the same value then a given starting program point L. ) open Cil_types -open Db_types -module IH = Inthash open Cil_datatype -module R : Plugin.S = +module R = Plugin.Register (struct let name = "scope" @@ -44,33 +42,34 @@ ) ( Statement identifier ) -module Sid = struct - include Datatype.Int - let default = -1 +module StmtDefault = struct + include Stmt + let default = Cil.dummyStmt end (** set of values to store for each data *) -module SidSet = struct +module StmtSetLattice = struct - include Abstract_interp.Make_Lattice_Set(Sid) + include Abstract_interp.Make_Lattice_Set(StmtDefault) - let default _v _a _b : t = inject_singleton Sid.default - let defaultall _v : t = inject_singleton Sid.default + let default _v _a _b : t = inject_singleton StmtDefault.default + let defaultall _v : t = inject_singleton StmtDefault.default let empty = bottom let cardinal set = fold (fun _ n -> n+1) set 0 - let single sid = inject_singleton sid + let single s = inject_singleton s let to_list ~keep_default set = - fold (fun n l -> if (n = Sid.default) && not keep_default then l else n::l) + fold + (fun n l -> if (n = StmtDefault.default) && not keep_default then l else n::l) set [] - let add sid set = join set (single sid) + let add s set = join set (single s) end (** A place to map each data to the state of statements that modify it. *) module InitSid = struct - module LM = Lmap_bitwise.Make_bitwise (SidSet) + module LM = Lmap_bitwise.Make_bitwise (StmtSetLattice) type t = LM.t @@ -78,7 +77,7 @@ let find = LM.find let add_zone ~exact lmap zone sid = - let new_val = SidSet.single sid in + let new_val = StmtSetLattice.single sid in let lmap = LM.add_binding exact lmap zone new_val in lmap @@ -91,14 +90,14 @@ Format.fprintf fmt "Lmap = %a@\n" LM.pretty lmap end -let get_lval_zones stmt lval = +let get_lval_zones ~for_writing stmt lval = let dpds, loc = !Db.Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode (Kstmt stmt) ~deps:Locations.Zone.bottom lval in - let zone = Locations.valid_enumerate_bits loc in - let exact = Locations.valid_cardinal_zero_or_one loc in + let zone = Locations.valid_enumerate_bits ~for_writing loc in + let exact = Locations.valid_cardinal_zero_or_one ~for_writing loc in dpds, exact, zone (** Add to [stmt] to [lmap] for all the locations modified by the statement. @@ -107,7 +106,7 @@ let register_modified_zones lmap stmt inst = let register lmap zone = (* [exact] should always be false because we want to store all the stmts ) - InitSid.add_zone ~exact:false lmap zone stmt.sid + InitSid.add_zone ~exact:false lmap zone stmt in let process_froms lmap froms = let from_table = froms.Function_Froms.deps_table in @@ -120,13 +119,16 @@ in match inst with | Set (lval, _, _) -> - let _dpds, _exact, zone = get_lval_zones stmt lval in - register lmap zone + let _dpds, _, zone = + get_lval_zones ~for_writing:true stmt lval + in + register lmap zone | Call (lvaloption,funcexp,_args,_) -> begin let lmap = match lvaloption with None -> lmap | Some lval -> - let _dpds, _exact, zone = get_lval_zones stmt lval in + let _dpds, _, zone = + get_lval_zones ~for_writing:true stmt lval in register lmap zone in try @@ -141,7 +143,7 @@ Kernel_function.Hptset.fold (fun kf lmap -> process_froms lmap (!Db.From.get kf)) called_functions - lmap + lmap end | _ -> lmap @@ -150,10 +152,10 @@ @raise Kernel_function.No_Definition if [kf] has no definition ) let compute kf = - R.debug ~level:1 "computing for function %a" Kernel_function.pretty_name kf; + R.debug ~level:1 "computing for function %a" Kernel_function.pretty kf; let f = Kernel_function.get_definition kf in let do_stmt lmap s = - if Db.Value.is_accessible (Kstmt s) then + if Db.Value.is_reachable_stmt s then match s.skind with | Instr i -> register_modified_zones lmap s i | _ -> lmap @@ -198,25 +200,26 @@ val pretty : Format.formatter -> t -> unit end) = struct + type key = stmt type data = S.t - type t = data IH.t + type t = data Stmt.Hashtbl.t - let states:t = IH.create 50 - let clear () = IH.clear states + let states:t = Stmt.Hashtbl.create 50 + let clear () = Stmt.Hashtbl.clear states - let add = IH.add states - let find = IH.find states - let mem = IH.mem states - let find = IH.find states - let replace = IH.replace states - let add = IH.add states - let iter f = IH.iter f states - let fold f = IH.fold f states - let length () = IH.length states + let add = Stmt.Hashtbl.add states + let find = Stmt.Hashtbl.find states + let mem = Stmt.Hashtbl.mem states + let find = Stmt.Hashtbl.find states + let replace = Stmt.Hashtbl.replace states + let add = Stmt.Hashtbl.add states + let iter f = Stmt.Hashtbl.iter f states + let fold f = Stmt.Hashtbl.fold f states + let length () = Stmt.Hashtbl.length states let pretty fmt infos = - IH.iter - (fun k v -> Format.fprintf fmt "Stmt:%d\n%a\n======" k S.pretty v) + Stmt.Hashtbl.iter + (fun k v -> Format.fprintf fmt "Stmt:%d\n%a\n======" k.sid S.pretty v) infos end @@ -247,12 +250,12 @@ let backward_data_scope allstmts modif_stmts s = States.clear (); - List.iter (fun s -> States.add s.sid State.NotSeen) allstmts; - let modified s = SidSet.mem s.sid modif_stmts in - States.replace s.sid State.Start; + List.iter (fun s -> States.add s State.NotSeen) allstmts; + let modified s = StmtSetLattice.mem s modif_stmts in + States.replace s State.Start; let stmts = s.preds in let module Computer = BackwardScope (struct let modified = modified end) in - let module Compute = Dataflow.BackwardsDataFlow(Computer) in + let module Compute = Dataflow.Backwards(Computer) in Compute.compute stmts module ForwardScope (X : sig val modified : stmt -> bool end ) = struct @@ -269,8 +272,9 @@ if state = State.Start then State.SameVal else state let combinePredecessors _stmt ~old new_ = - assert (R.verify (new_ <> State.Start) - "forward traversal shouldn't go through Start !"); + if new_ = State.Start then + R.error "forward traversal shouldn't go through Start, stmt %d, prev %a !" + _stmt.sid State.pretty old; State.test_and_merge ~old new_ let doStmt _stmt _state = Dataflow.SDefault @@ -288,20 +292,20 @@ let forward_data_scope modif_stmts s = States.clear (); - let modified s = SidSet.mem s.sid modif_stmts in + let modified s = StmtSetLattice.mem s modif_stmts in let module Computer = ForwardScope (struct let modified = modified end) in - let module Compute = Dataflow.ForwardsDataFlow(Computer) in - States.replace s.sid State.Start; + let module Compute = Dataflow.Forwards(Computer) in + States.replace s State.Start; Compute.compute [s] -let add_s sid acc = - let s, _ = Kernel_function.find_from_sid sid in - ( we add only 'simple' statements ) - match s.skind with - | Instr _ | Return _ | Continue _ | Break _ | Goto _ +( XXX ) +let add_s s acc = + ( we add only 'simple' statements *) + match s.skind with + | Instr _ | Return _ | Continue _ | Break _ | Goto _ -> Stmt.Set.add s acc - | Block _ | Switch _ | If _ | UnspecifiedSequence _ | Loop _ - | TryExcept _ | TryFinally _ + | Block _ | Switch _ | If _ | UnspecifiedSequence _ | Loop _ + | TryExcept _ | TryFinally _ -> acc (** Do backward and then forward propagations and compute the 3 statement sets : @@ -310,17 +314,17 @@ * - backward only. ) let find_scope allstmts modif_stmts s = - let add fw sid x acc = + let add fw s' x acc = match x with | State.Start -> - if fw then add_s sid acc + if fw then add_s s' acc else let x = - List.fold_left (fun x s -> State.merge x (States.find s.sid)) + List.fold_left (fun x s -> State.merge x (States.find s)) State.NotSeen s.succs - in let x = State.transfer (SidSet.mem sid modif_stmts) x in - if x = State.SameVal then add_s sid acc else acc - | State.SameVal -> add_s sid acc + in let x = State.transfer (StmtSetLattice.mem s' modif_stmts) x in + if x = State.SameVal then add_s s' acc else acc + | State.SameVal -> add_s s' acc | _ -> acc in let _ = backward_data_scope allstmts modif_stmts s in @@ -339,7 +343,7 @@ @raise Kernel_function.No_Definition if [kf] has no definition ) let get_data_scope_at_stmt kf stmt lval = - let dpds, _exact, zone = get_lval_zones stmt lval in + let dpds, _, zone = get_lval_zones ~for_writing:false stmt lval in ( TODO : is there something to do with 'exact' ? ) let zone = Locations.Zone.join dpds zone in let allstmts, info = compute kf in @@ -354,8 +358,8 @@ ( stmt at ) Locations.Zone.pretty zone stmt.sid ( modified by ) - (Cilutil.print_list Cilutil.space Sid.pretty) - (SidSet.to_list ~keep_default:false modif_stmts) + (Cilutil.pretty_list (Cilutil.space_sep " ") Stmt.pretty_sid) + (StmtSetLattice.to_list ~keep_default:false modif_stmts) ( scope *) Stmt.Set.pretty f_scope Stmt.Set.pretty fb_scope @@ -378,9 +382,9 @@ raise ToDo in let (info, _), _ = - !Db.Properties.Interp.To_zone.from_stmt_annot annot - ~before:true (stmt, kf) - in match info with + !Db.Properties.Interp.To_zone.from_stmt_annot annot (stmt, kf) + in + match info with | None -> raise ToDo | Some info -> let zone = List.fold_left add_zone Locations.Zone.bottom info in @@ -406,7 +410,7 @@ let check_stmt_annots pred s acc = let check acc annot = match annot with - | Before (AI (_, ({annot_content= AAssert (_, p) } as annot))) -> + | (AI (_, ({annot_content= AAssert (_, p) } as annot))) -> if Logic_utils.is_same_named_predicate p pred then begin let acc, added = add_annot annot acc in @@ -418,7 +422,7 @@ else acc | _ -> acc in - List.fold_left check acc (Annotations.get_filter Logic_utils.is_assert s) + List.fold_left check acc (Annotations.get_all_annotations s) (** Return the set of stmts (scope) where [annot] has the same value * than in [stmt] @@ -427,7 +431,7 @@ * ) let get_prop_scope_at_stmt kf stmt ?(to_be_removed=[]) annot = R.debug "[get_prop_scope_at_stmt] at stmt %d in %a : %a" - stmt.sid Kernel_function.pretty_name kf + stmt.sid Kernel_function.pretty kf !Ast_printer.d_code_annotation annot; let sets = (Stmt.Set.empty, to_be_removed) in @@ -441,18 +445,17 @@ | AAssert (_, p) -> p | _ -> R.abort "only 'assert' are handeled here" in - let add sid x ((acc_scope, acc_to_be_rm) as acc) = + let add s x ((acc_scope, acc_to_be_rm) as acc) = match x with - | State.Start -> (add_s sid acc_scope, acc_to_be_rm) + | State.Start -> (add_s s acc_scope, acc_to_be_rm) | State.SameVal -> - let s, _ = Kernel_function.find_from_sid sid in - if !Db.Dominators.is_dominator kf ~opening:stmt ~closing:s - then begin - let acc_scope = add_s sid acc_scope in - let acc_to_be_rm = check_stmt_annots pred s acc_to_be_rm in - (acc_scope, acc_to_be_rm) - end - else acc + if !Db.Dominators.is_dominator kf ~opening:stmt ~closing:s + then begin + let acc_scope = add_s s acc_scope in + let acc_to_be_rm = check_stmt_annots pred s acc_to_be_rm in + (acc_scope, acc_to_be_rm) + end + else acc | _ -> acc in let sets = States.fold add sets in @@ -483,7 +486,7 @@ | AAssert (_, _) -> if before then begin R.debug ~level:2 "[check] annot %d at stmt %d in %a : %a@." - annot.annot_id stmt.sid Kernel_function.pretty_name kf + annot.annot_id stmt.sid Kernel_function.pretty kf !Ast_printer.d_code_annotation annot; let _, added = add_annot annot to_be_removed in ( just check if [annot] is in [to_be_removed] : @@ -563,7 +566,7 @@ (Db.Journalize ("Scope.get_data_scope_at_stmt", Datatype.func3 - Kernel_function.ty + Kernel_function.ty Stmt.ty Lval.ty (Datatype.pair Stmt.Set.ty (Datatype.pair Stmt.Set.ty Stmt.Set.ty)))) @@ -591,3 +594,9 @@ ("Scope.rm_asserts", Datatype.func Datatype.unit Datatype.unit)) Db.Scope.rm_asserts rm_asserts; + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/scope/defs.ml frama-c-20111001+nitrogen+dfsg/src/scope/defs.ml --- frama-c-20110201+carbon+dfsg/src/scope/defs.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/scope/defs.ml 2011-10-10 08:38:30.000000000 +0000 @@ -0,0 +1,154 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( INRIA (Institut National de Recherche en Informatique et en ) +( Automatique) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version v2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Find the statements that defines a given data at a program point, +* ie. in each backward path starting from this point, find the statement +* the the data has been assigned for the last time. ) + +open Cil_datatype +open Cil_types + +let debug1 fmt = Datascope.R.debug ~level:1 fmt +let debug2 fmt = Datascope.R.debug ~level:2 fmt + +module Interproc = + Datascope.R.True(struct + let option_name = "-scope-defs-interproc" + let help = "interprocedural defs computation" + let kind = `Tuning + end) + + +let rec add_callee_nodes acc nodes = + let new_nodes, acc = List.fold_left (fun acc2 (node,_) -> + match !Db.Pdg.node_key node with + | PdgIndex.Key.SigCallKey (cid,(PdgIndex.Signature.Out out_key)) -> + let callees = + Db.Value.call_to_kernel_function (PdgIndex.Key.call_from_id cid) + in + Kernel_function.Hptset.fold (fun kf (new_nodes, acc) -> + let callee_pdg = !Db.Pdg.get kf in + let outputs = fst (!Db.Pdg.find_output_nodes callee_pdg out_key) in + outputs @ new_nodes, outputs @ acc) + callees + acc2 + | _ -> acc2) + ([], acc) + nodes + in match new_nodes with [] -> acc + | _ -> add_callee_nodes acc new_nodes + +let rec add_caller_nodes kf acc (undef,nodes) = + let callers = !Db.Value.callers kf in + List.fold_left + (fun acc (kf,stmts) -> + let pdg = !Db.Pdg.get kf in + let acc_undef,caller_nodes = + List.fold_left (fun (acc_undef,acc) stmt -> + let nodes_for_undef, undef' = + !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true + undef + in + let acc_undef = match undef' with + | None -> acc_undef + | Some z -> Locations.Zone.join acc_undef z + in + List.fold_left (fun (acc_undef,acc) (node,_) -> + match !Db.Pdg.node_key node with + | PdgIndex.Key.SigKey (PdgIndex.Signature.In in_key) -> + begin match in_key with + | PdgIndex.Signature.InCtrl ->( We only look for the values ) + acc_undef,acc + | PdgIndex.Signature.InNum n_param -> + acc_undef, + (!Db.Pdg.find_call_input_node pdg stmt n_param,None)::acc + | PdgIndex.Signature.InImpl z -> + let nodes,undef'= + !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true z + in + let acc_undef = match undef' with + | None -> acc_undef + | Some z -> Locations.Zone.join acc_undef z + in + + acc_undef, nodes@acc + end + | _ -> acc_undef,acc) + (acc_undef,nodes_for_undef@acc) + nodes) + (Locations.Zone.bottom,[]) + stmts + in + add_caller_nodes kf (caller_nodes@acc) (acc_undef,caller_nodes)) + acc + callers + +let compute kf stmt lval = + debug1 "[Defs.compute] for %a at sid:%d in '%a'@." + !Ast_printer.d_lval lval stmt.sid Kernel_function.pretty kf; + try + let pdg = !Db.Pdg.get kf in + let zone = !Db.Value.lval_to_zone (Kstmt stmt) + ~with_alarms:CilE.warn_none_mode lval + in + let nodes, undef = + !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true zone + in + let nodes = + if Interproc.get () then + begin + let caller_nodes = + add_caller_nodes kf nodes + ((match undef with None -> Locations.Zone.bottom | Some z -> z), + nodes) + in add_callee_nodes caller_nodes caller_nodes + end + else nodes + in + let add_node defs (node,_z) = + match PdgIndex.Key.stmt (!Db.Pdg.node_key node) with + | None -> defs + | Some s -> Stmt.Set.add s defs + in + ( select corresponding stmts ) + let defs = List.fold_left add_node Stmt.Set.empty nodes in + Some (defs, undef) + with Db.Pdg.Bottom | Db.Pdg.Top | Not_found -> + None + + (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) + +let () = + Db.register ( kernel_function -> stmt -> lval -> + (Cilutil.StmtSet.t * Locations.Zone.t option) option *) + (Db.Journalize + ("Scope.get_defs", + Datatype.func3 + Kernel_function.ty + Stmt.ty + Lval.ty + (Datatype.option + (Datatype.pair Stmt.Set.ty (Datatype.option Locations.Zone.ty))))) + Db.Scope.get_defs compute + diff -Nru frama-c-20110201+carbon+dfsg/src/scope/defs.mli frama-c-20111001+nitrogen+dfsg/src/scope/defs.mli --- frama-c-20110201+carbon+dfsg/src/scope/defs.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/scope/defs.mli 2011-10-10 08:38:30.000000000 +0000 @@ -0,0 +1,27 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( INRIA (Institut National de Recherche en Informatique et en ) +( Automatique) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version v2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* + This file is empty on purpose. Plugins register callbacks in src/kernel/db.ml. +) diff -Nru frama-c-20110201+carbon+dfsg/src/scope/dpds_gui.ml frama-c-20111001+nitrogen+dfsg/src/scope/dpds_gui.ml --- frama-c-20110201+carbon+dfsg/src/scope/dpds_gui.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/scope/dpds_gui.ml 2011-10-10 08:38:30.000000000 +0000 @@ -22,16 +22,15 @@ ( *) (**************************************************************************) -open Properties_status open Pretty_source open Cil_types open Cil_datatype -open Db_types + +let update_visibility = ref (fun () -> ()) let add_tag buffer (name, tag_prop) start stop = - (* TODO : maybe we should use lazy to build the each tag only once ?... ) let tag = Gtk_helper.make_tag buffer ~name tag_prop in - Gtk_helper.apply_tag buffer tag start stop + Gtk_helper.apply_tag buffer tag start stop let scope_start_tag = ("startscope", [`UNDERLINE `DOUBLE]) let zones_used_tag = ("zones", [`BACKGROUND "#FFeeCC"]) @@ -56,8 +55,8 @@ try let term_lval = !Db.Properties.Interp.lval kf stmt txt in let lval = - !Db.Properties.Interp.term_lval_to_lval ~result:None term_lval - in + !Db.Properties.Interp.term_lval_to_lval ~result:None term_lval + in Some (txt, lval) with e -> main_ui#error "[ask for lval] '%s' invalid expression: %s@." @@ -84,14 +83,26 @@ Some (lv_txt, lv) | _ -> ( match kf_stmt_opt with - None -> None + None -> None | Some (kf, stmt) -> match (ask_for_lval main_ui kf stmt) with - None -> None + None -> None | Some (lv_txt, lv) -> Some (lv_txt, lv)) +module Kf_containing_highlighted_stmt = + Kernel_function.Make_Table + (Datatype.Unit) + (struct + let name = "Dpds_gui.Kf_containing_highlighted_stmt" + let size = 7 + let dependencies = + [ (Dependencies are managed manually by Make_StmtSetState*) ] + let kind = `Internal + end) + + module Make_StmtSetState (Info:sig val name: string end) = - State_builder.Ref + struct include State_builder.Ref (Stmt.Set) (struct let name = Info.name @@ -99,7 +110,18 @@ let kind = `Internal let default () = Stmt.Set.empty end) + + let set s = + set s; + Kf_containing_highlighted_stmt.clear (); + Stmt.Set.iter + (fun stmt -> + Kf_containing_highlighted_stmt.replace + (Kernel_function.find_englobing_kf stmt) ()) + s; + !update_visibility () + end module type DpdCmdSig = sig type t_in val help : string @@ -164,9 +186,9 @@ State_builder.List_ref (Code_annotation) (struct - let name = "Dpds_gui.Highlighter.Pscope_warn" - let dependencies = [ Db.Value.self ] - let kind = `Internal + let name = "Dpds_gui.Highlighter.Pscope_warn" + let dependencies = [ Db.Value.self ] + let kind = `Internal end) let clear () = Pscope.clear(); Pscope_warn.clear() @@ -216,7 +238,7 @@ let get_info _kf_stmt_opt = if Stmt.Set.is_empty (ShowDefState.get()) then "" else "[show_def] selected" - + let compute kf stmt lv = match !Db.Scope.get_defs kf stmt lv with | None -> clear (); "[show_def] nothing found..." @@ -241,16 +263,25 @@ type t_in = lval module ZonesState = - State_builder.Option_ref + struct include State_builder.Option_ref (Datatype.Pair - (Int_hashtbl.Make(Locations.Zone)) + (Stmt.Hashtbl.Make(Locations.Zone)) (Stmt.Set)) (struct let name = "Dpds_gui.Highlighter.ZonesState" let dependencies = [ Db.Value.self ] let kind = `Internal end) - + let set s = + set s; + Kf_containing_highlighted_stmt.clear (); + Stmt.Set.iter + (fun stmt -> + Kf_containing_highlighted_stmt.replace + (Kernel_function.find_englobing_kf stmt) ()) + (snd s); + !update_visibility () + end let clear () = ZonesState.clear () let help = @@ -318,7 +349,10 @@ ShowDef.clear (); Zones.clear (); DataScope.clear (); - Pscope.clear () + Pscope.clear (); + Kf_containing_highlighted_stmt.clear (); + !update_visibility () + let print_info main_ui kf_stmt_opt = try @@ -353,7 +387,7 @@ let set_txt x = let txt = Pretty_utils.sfprintf "[dependencies] for %s before stmt %d in %a" - x stmt.sid Kernel_function.pretty_name kf + x stmt.sid Kernel_function.pretty kf in DpdsState.set (kf, stmt, txt); add_msg main_ui txt @@ -401,6 +435,22 @@ | PVDecl _ | PTermLval _ | PLval _ | PGlobal _ | PIP _ -> () with Not_found -> () +let check_value (main_ui:Design.main_window_extension_points) = + if Db.Value.is_computed () then true + else + let answer = GToolbox.question_box + ~title:("Need Value Analysis") + ~buttons:[ "Run"; "Cancel" ] + ("Value analysis has to be run first.\nThis can take some time.\n" + ^"Do you want to run the value analysis now ?") + in + if answer = 1 then + match main_ui#full_protect ~cancelable:true !Db.Value.compute with + | Some _ -> true + | None -> false + else false + + (** To add a sensitive/unsensitive menu item to a [factory]. * The menu item is insensitive when [arg_opt = None], * else, when the item is selected, the callback is called with the argument. @@ -408,19 +458,17 @@ ) let add_item (main_ui:Design.main_window_extension_points) ~use_values (factory:GMenu.menu GMenu.factory) name arg_opt callback = - if use_values && not (Db.Value.is_computed ()) then - ( add the menu item asking for running value analysis ) - let callback () = - let msg = "You need to Execute Values analysis first." in - add_msg main_ui ("[" ^ name ^ "] " ^ msg) - in ignore (factory#add_item name ~callback) - else match arg_opt with | None -> ( add the menu item, but it isn't sensitive ) let item = factory#add_item name ~callback: (fun () -> ()) in item#misc#set_sensitive false | Some arg -> ( add the menu item with its callback ) - ignore (factory#add_item name ~callback: (fun () -> callback arg)) + let cb arg = + if use_values then + if check_value main_ui then callback arg else () + else callback arg + in + ignore (factory#add_item name ~callback: (fun () -> cb arg)) let selector (popup_factory:GMenu.menu GMenu.factory) (main_ui:Design.main_window_extension_points) @@ -458,8 +506,28 @@ else if button = 1 then print_info main_ui (get_kf_stmt_opt localizable) +let filetree_decorate main_ui = + main_ui#file_tree#append_pixbuf_column + ~title:"Scope" + (fun globs -> + let is_hilighted = function + | GFun ({svar = v }, _) -> + Kf_containing_highlighted_stmt.mem (Globals.Functions.get v) + | _ -> false + in + let id = + ( lazyness of && is used for efficiency *) + if (Kf_containing_highlighted_stmt.length () <> 0) + && List.exists is_hilighted globs + then "gtk-apply" + else "" + in + [ `STOCK_ID id ]) + (fun _ -> Kf_containing_highlighted_stmt.length () <>0) + let main main_ui = main_ui#register_source_selector selector; - main_ui#register_source_highlighter highlighter - + main_ui#register_source_highlighter highlighter; + update_visibility := (filetree_decorate main_ui) + let () = Design.register_extension main diff -Nru frama-c-20110201+carbon+dfsg/src/scope/zones.ml frama-c-20111001+nitrogen+dfsg/src/scope/zones.ml --- frama-c-20110201+carbon+dfsg/src/scope/zones.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/scope/zones.ml 2011-10-10 08:38:30.000000000 +0000 @@ -23,7 +23,8 @@ (**************************************************************************) module R = Datascope.R -module IH = Inthash +let debug1 fmt = R.debug ~level:1 fmt +let debug2 fmt = R.debug ~level:2 fmt open Cil_datatype open Cil_types @@ -37,21 +38,21 @@ let diff = Locations.Zone.diff (* over-approx ) let pretty fmt z = Format.fprintf fmt "@[<h 1>%a@]" Locations.Zone.pretty z - let exp_zone stmt exp = !Db.From.find_deps_no_transitivity (Kstmt stmt) exp + let exp_zone stmt exp = !Db.From.find_deps_no_transitivity stmt exp end module Ctx = struct - type t = Data.t IH.t - let create = IH.create - let find = IH.find + type t = Data.t Stmt.Hashtbl.t + let create = Stmt.Hashtbl.create + let find = Stmt.Hashtbl.find let add ctx k d = let d = try let old_d = find ctx k in Data.merge old_d d with Not_found -> d - in IH.replace ctx k d - ( let mem = IH.mem : useless because Ctx has to be initialized to bot ) + in Stmt.Hashtbl.replace ctx k d + ( let mem = Stmt.Hashtbl.mem : useless because Ctx has to be initialized to bot ) let pretty fmt infos = - IH.iter - (fun k d -> Format.fprintf fmt "Stmt:%d -> %a@\n" k Data.pretty d) + Stmt.Hashtbl.iter + (fun k d -> Format.fprintf fmt "Stmt:%d -> %a@\n" k.sid Data.pretty d) infos end @@ -70,7 +71,8 @@ | Some lval -> let ret_dpds = froms.Function_Froms.deps_return in let r_dpds = Lmap_bitwise.From_Model.LOffset.collapse ret_dpds in - let l_dpds, exact, l_zone = Datascope.get_lval_zones stmt lval in + let l_dpds, exact, l_zone = + Datascope.get_lval_zones ~for_writing:true stmt lval in compute_new_data data l_zone l_dpds exact r_dpds in data @@ -151,18 +153,18 @@ (process_one_call data_after stmt lvaloption (!Db.From.get kf))::acc in let l = Kernel_function.Hptset.fold do_call called_functions [] in - ( in l, we have one result for each possible function called ) + ( in l, we have one result for each possible function called ) List.fold_left (fun (acc_u,acc_d) (u,d) -> (acc_u || u), Data.merge acc_d d) (false, Data.bottom) - l + l in if used then let data = ( no problem of order because parameters are disjoint for sure ) Kernel_function.Hptset.fold - (fun kf data -> process_call_args data kf stmt args) - called_functions + (fun kf data -> process_call_args data kf stmt args) + called_functions data in let data = Data.merge funcexp_dpds data in @@ -188,13 +190,14 @@ module StmtStartData = struct type data = t - let clear () = IH.clear Param.states - let mem = IH.mem Param.states - let find = IH.find Param.states - let replace = IH.replace Param.states - let add = IH.add Param.states - let iter f = IH.iter f Param.states - let length () = IH.length Param.states + type key = stmt + let clear () = Stmt.Hashtbl.clear Param.states + let mem = Stmt.Hashtbl.mem Param.states + let find = Stmt.Hashtbl.find Param.states + let replace = Stmt.Hashtbl.replace Param.states + let add = Stmt.Hashtbl.add Param.states + let iter f = Stmt.Hashtbl.iter f Param.states + let length () = Stmt.Hashtbl.length Param.states end let combineStmtStartData _stmt ~old new_ = @@ -208,7 +211,8 @@ let doInstr stmt instr data = match instr with | Set (lval, exp, _) -> - let l_dpds, exact, l_zone = Datascope.get_lval_zones stmt lval in + let l_dpds, exact, l_zone = + Datascope.get_lval_zones ~for_writing:true stmt lval in let r_dpds = Data.exp_zone stmt exp in let used, data = compute_new_data data l_zone l_dpds exact r_dpds in let _ = if used then add_used_stmt stmt in @@ -220,8 +224,6 @@ | _ -> Dataflow.Default let filterStmt _stmt _next = true - ( assert (Db.ToReturn.is_accessible (Kstmt next)); - Db.ToReturn.is_accessible (Kstmt stmt) ) let funcExitData = Data.bottom @@ -229,34 +231,34 @@ let compute_ctrl_info pdg ctrl_part used_stmts = let module CtrlComputer = Computer (struct let states = ctrl_part end) in - let module CtrlCompute = Dataflow.BackwardsDataFlow(CtrlComputer) in - let seen = IH.create 50 in + let module CtrlCompute = Dataflow.Backwards(CtrlComputer) in + let seen = Stmt.Hashtbl.create 50 in let rec add_node_ctrl_nodes new_stmts node = let ctrl_nodes = !Db.Pdg.direct_ctrl_dpds pdg node in List.fold_left add_ctrl_node new_stmts ctrl_nodes and add_ctrl_node new_stmts ctrl_node = - R.debug ~level:2 "[zones] add ctrl node %a@." PdgTypes.Node.pretty ctrl_node; + debug2 "[zones] add ctrl node %a@." PdgTypes.Node.pretty ctrl_node; match PdgTypes.Node.stmt ctrl_node with | None -> ( node without stmt : add its ctrl_dpds ) add_node_ctrl_nodes new_stmts ctrl_node | Some stmt -> - R.debug ~level:2 "[zones] node %a is stmt %d@." + debug2 "[zones] node %a is stmt %d@." PdgTypes.Node.pretty ctrl_node stmt.sid; - if IH.mem seen stmt.sid then new_stmts + if Stmt.Hashtbl.mem seen stmt then new_stmts else let ctrl_zone = match stmt.skind with | Switch (exp,_,_,_) | If (exp,_,_,_) -> Data.exp_zone stmt exp | _ -> Data.bottom - in Ctx.add ctrl_part stmt.sid ctrl_zone; - IH.add seen stmt.sid (); - R.debug ~level:2 "[zones] add ctrl zone %a at stmt %d@." + in Ctx.add ctrl_part stmt ctrl_zone; + Stmt.Hashtbl.add seen stmt (); + debug2 "[zones] add ctrl zone %a at stmt %d@." Data.pretty ctrl_zone stmt.sid; stmt::new_stmts and add_stmt_ctrl new_stmts stmt = - R.debug ~level:1 "[zones] add ctrl of stmt %d@." stmt.sid; - if IH.mem seen stmt.sid then new_stmts + debug1 "[zones] add ctrl of stmt %d@." stmt.sid; + if Stmt.Hashtbl.mem seen stmt then new_stmts else begin - IH.add seen stmt.sid (); + Stmt.Hashtbl.add seen stmt (); match !Db.Pdg.find_simple_stmt_nodes pdg stmt with | [] -> [] | n::_ -> add_node_ctrl_nodes new_stmts n @@ -275,15 +277,16 @@ let compute kf stmt lval = let f = Kernel_function.get_definition kf in - let dpds, _exact, zone = Datascope.get_lval_zones stmt lval in + let dpds, _exact, zone = + Datascope.get_lval_zones ~for_writing:false stmt lval in let zone = Data.merge dpds zone in - R.debug ~level:1 "[zones] build for %a before %d in %a@\n" - Data.pretty zone stmt.sid Kernel_function.pretty_name kf; + debug1 "[zones] build for %a before %d in %a@\n" + Data.pretty zone stmt.sid Kernel_function.pretty kf; let data_part = Ctx.create 50 in - List.iter (fun s -> Ctx.add data_part s.sid Data.bottom) f.sallstmts; - let _ = Ctx.add data_part stmt.sid zone in + List.iter (fun s -> Ctx.add data_part s Data.bottom) f.sallstmts; + let _ = Ctx.add data_part stmt zone in let module DataComputer = Computer (struct let states = data_part end) in - let module DataCompute = Dataflow.BackwardsDataFlow(DataComputer) in + let module DataCompute = Dataflow.Backwards(DataComputer) in let _ = DataCompute.compute stmt.preds in let ctrl_part = data_part ( Ctx.create 50 ) in ( it is confusing to have 2 part in the provided information, @@ -301,34 +304,11 @@ all_used_stmts, data_part let get stmt_zones stmt = - try Ctx.find stmt_zones stmt.sid with Not_found -> Data.bottom + try Ctx.find stmt_zones stmt with Not_found -> Data.bottom let pretty fmt stmt_zones = - let pp s d = Format.fprintf fmt "Stmt:%d -> %a@." s Data.pretty d - in IH.iter pp stmt_zones - - (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) - -let compute_defs kf stmt lval = - (* TODO : move this function somewhere else ? ) - try - let pdg = !Db.Pdg.get kf in - let zone = !Db.Value.lval_to_zone (Kstmt stmt) - ~with_alarms:CilE.warn_none_mode lval - in - let nodes, undef = - !Db.Pdg.find_location_nodes_at_stmt pdg stmt ~before:true zone - in - let add_node defs (node,_z) = - match PdgIndex.Key.stmt (!Db.Pdg.node_key node) with - | None -> defs - | Some s -> Stmt.Set.add s defs - in - ( select corresponding stmts ) - let defs = List.fold_left add_node Stmt.Set.empty nodes in - Some (defs, undef) - with Db.Pdg.Bottom | Db.Pdg.Top | Db.Pdg.NotFound -> - None + let pp s d = Format.fprintf fmt "Stmt:%d -> %a@." s.sid Data.pretty d + in Stmt.Hashtbl.iter pp stmt_zones (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) @@ -355,16 +335,3 @@ ((Db.Journalize("Scope.pretty_zones", Datatype.func Datatype.formatter (Datatype.func zones_ty Datatype.unit)))) Db.Scope.pretty_zones pretty; - - Db.register ( kernel_function -> stmt -> lval -> - (Cilutil.StmtSet.t * Locations.Zone.t option) option ) - (Db.Journalize - ("Scope.get_defs", - Datatype.func3 - Kernel_function.ty - Stmt.ty - Lval.ty - (Datatype.option - (Datatype.pair Stmt.Set.ty (Datatype.option Locations.Zone.ty))))) - Db.Scope.get_defs compute_defs - diff -Nru frama-c-20110201+carbon+dfsg/src/scope/zones.mli frama-c-20111001+nitrogen+dfsg/src/scope/zones.mli --- frama-c-20110201+carbon+dfsg/src/scope/zones.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/scope/zones.mli 2011-10-10 08:38:30.000000000 +0000 @@ -22,6 +22,6 @@ ( *) (**************************************************************************) -(* +(* This file is empty on purpose. Plugins register callbacks in src/kernel/db.ml. ) diff -Nru frama-c-20110201+carbon+dfsg/src/security_slicing/components.ml frama-c-20111001+nitrogen+dfsg/src/security_slicing/components.ml --- frama-c-20110201+carbon+dfsg/src/security_slicing/components.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/security_slicing/components.ml 2011-10-10 08:38:07.000000000 +0000 @@ -23,7 +23,6 @@ open Cil_types open Cil open Cil_datatype -open Db_types open Db open Extlib @@ -43,15 +42,15 @@ | Pand(p1, p2) -> is_security_predicate p1 || is_security_predicate p2 | ( [state(lval) op term] ) Prel(_, - { term_node = Tapp(f1, _ , ([ _ ])) }, - { term_node = TLval(TVar _,_) }) - when f1.l_var_info.lv_name = Model.state_name -> + { term_node = Tapp(f1, _ , ([ _ ])) }, + { term_node = TLval(TVar _,_) }) + when f1.l_var_info.lv_name = Model.state_name -> true | ( [state(lval) op term] ) Prel(_, - { term_node = Tapp(f1, _, [ _ ]) }, - { term_node = _ }) - when f1.l_var_info.lv_name = Model.state_name -> + { term_node = Tapp(f1, _, [ _ ]) }, + { term_node = _ }) + when f1.l_var_info.lv_name = Model.state_name -> assert false | _ -> false @@ -68,35 +67,35 @@ ( TODO: chercher dans les GlobalAnnotations ) let is_security_annotation = function | User a -> - (match a.annot_content with - | AAssert (_behav,p,_) -> is_security_predicate p - | AStmtSpec { spec_requires = l } -> - List.exists - (is_security_predicate $ Logic_const.pred_of_id_pred) l - | APragma _ + (match a.annot_content with + | AAssert (_behav,p,_) -> is_security_predicate p + | AStmtSpec { spec_requires = l } -> + List.exists + (is_security_predicate $ Logic_const.pred_of_id_pred) l + | APragma _ | AInvariant _ ( | ALoopBehavior _ ) - ( [JS 2008/02/26] may contain a security predicate ) + ( [JS 2008/02/26] may contain a security predicate ) | AVariant _ | AAssigns _ -> false) | AI _ -> - false + false in Annotations.iter (fun s annotations -> - if - Value.is_reachable_stmt s - && List.exists - (function Before a | After a -> is_security_annotation a) - !annotations - then - Security_Annotations.add s); + if + Value.is_reachable_stmt s + && List.exists + (function Before a | After a -> is_security_annotation a) + !annotations + then + Security_Annotations.add s); Globals.Functions.iter (fun kf -> - if has_security_requirement kf then - List.iter - (fun (_, callsites) -> - List.iter Security_Annotations.add callsites) - (!Value.callers kf)); + if has_security_requirement kf then + List.iter + (fun (_, callsites) -> + List.iter Security_Annotations.add callsites) + (!Value.callers kf)); end ) (* ************************************************************************* ) @@ -135,8 +134,8 @@ module Callstack = struct type t = - { mutable stack: (stmt kernel_function) list; - mutable current_kf: kernel_function } + { mutable stack: (stmt * kernel_function) list; + mutable current_kf: kernel_function } let init kf callstack = callstack.stack <- []; callstack.current_kf <- kf @@ -151,14 +150,14 @@ let equal s1 s2 = Kernel_function.equal s1.current_kf s2.current_kf && try - List.iter2 - (fun (s1, kf1) (s2, kf2) -> - if not (s1.sid = s2.sid && Kernel_function.equal kf1 kf2) then - raise Exit) - s1.stack s2.stack; - true + List.iter2 + (fun (s1, kf1) (s2, kf2) -> + if not (s1.sid = s2.sid && Kernel_function.equal kf1 kf2) then + raise Exit) + s1.stack s2.stack; + true with Exit -> - false + false let hash = Hashtbl.hash @@ -180,29 +179,41 @@ include Hashtbl let memo tbl k callstack = try - let callstacks = find tbl k in - Callstacks.memo callstacks callstack + let callstacks = find tbl k in + Callstacks.memo callstacks callstack with Not_found -> - let callstacks = Callstacks.create 7 in - let t = Nodekfs.create 7 in - Callstacks.replace callstacks callstack t; - replace tbl k callstacks; - t + let callstacks = Callstacks.create 7 in + let t = Nodekfs.create 7 in + Callstacks.replace callstacks callstack t; + replace tbl k callstacks; + t end type local_tbl = (Pdg.t_node * kernel_function) list Nodekfs.t type state = { mutable kind: kind; - mutable callstack: Callstack.t; - mutable local_tbl: local_tbl; - memo_tbl: (kind, local_tbl Callstacks.t) Memo.t; } + mutable callstack: Callstack.t; + mutable local_tbl: local_tbl; + memo_tbl: (kind, local_tbl Callstacks.t) Memo.t; } (* *********************************************************************** ) let state = + let spec = Cil.empty_funspec () in { kind = Backward Direct; callstack = - { Callstack.stack = []; current_kf = Kernel_function.dummy () }; + { Callstack.stack = []; + current_kf = + { fundec = + ( do not use Cil.emptyFunction here since it changes the + numerotation of variables ) + Declaration + (spec, + Cil_datatype.Varinfo.dummy, + None, + Cil_datatype.Location.unknown); + return_stmt = None; + spec = Cil.empty_funspec () } }; local_tbl = Nodekfs.create 0; memo_tbl = Hashtbl.create 5 } @@ -237,10 +248,10 @@ module Todolist : sig type todo = private { node: Pdg.t_node; - kf: kernel_function; - pdg: Pdg.t; - callstack_length: int; - from_deep: bool } + kf: kernel_function; + pdg: Pdg.t; + callstack_length: int; + from_deep: bool } type t = todo list val mk_init: kernel_function -> Pdg.t -> Pdg.t_node list -> todo list val add: Pdg.t_node -> kernel_function -> Pdg.t -> int -> bool -> t -> t @@ -248,30 +259,30 @@ type todo = { node: Pdg.t_node; - kf: kernel_function; - pdg: Pdg.t; - callstack_length: int; - from_deep: bool } + kf: kernel_function; + pdg: Pdg.t; + callstack_length: int; + from_deep: bool } type t = todo list let add n kf pdg len fd list = match !Pdg.node_key n with | Key.SigKey (Signature.In Signature.InCtrl) -> - ( do not consider node [InCtrl] ) - list - | Key.VarDecl vi when not (Parameters.LibEntry.get () && vi.vglob) -> - ( do not consider variable declaration, - except if libEntry is set and they are globals - (i.e. we could have no further info about them) ) - list + ( do not consider node [InCtrl] ) + list + | Key.VarDecl vi when not (Kernel.LibEntry.get () && vi.vglob) -> + ( do not consider variable declaration, + except if libEntry is set and they are globals + (i.e. we could have no further info about them) ) + list | _ -> - Security_slicing_parameters.debug ~level:2 "adding node %a (in %s)" - (!Pdg.pretty_node false) n - (Kernel_function.get_name kf); - { node = n; kf = kf; pdg = pdg; - callstack_length = len; from_deep = fd } - :: list + Security_slicing_parameters.debug ~level:2 "adding node %a (in %s)" + (!Pdg.pretty_node false) n + (Kernel_function.get_name kf); + { node = n; kf = kf; pdg = pdg; + callstack_length = len; from_deep = fd } + :: list let mk_init kf pdg = List.fold_left (fun acc n -> add n kf pdg 0 false acc) [] @@ -293,10 +304,10 @@ type value = { pdg: Pdg.t; - mutable callstack_length: int; - mutable direct: bool; - mutable indirect_backward: bool; - mutable forward: bool } + mutable callstack_length: int; + mutable direct: bool; + mutable indirect_backward: bool; + mutable forward: bool } type t = value M.t @@ -310,15 +321,15 @@ value. ) let check_and_add first elt kind pdg len already = try - (* Format.printf "[security] check node %a (in %s, kind %a)@." - (!Pdg.pretty_node true) (fst elt) - (Kernel_function.get_name (snd elt)) - pretty_kind kind;) + ( Format.printf "[security] check node %a (in %s, kind %a)@." + (!Pdg.pretty_node true) (fst elt) + (Kernel_function.get_name (snd elt)) + pretty_kind kind;) let v = M.find elt already in let found, dir, up, down = match kind with - | Direct -> true, true, false, false - | Indirect_Backward -> v.indirect_backward, v.direct, true, false - | Forward _ -> v.forward, v.direct, v.indirect_backward, true + | Direct -> true, true, false, false + | Indirect_Backward -> v.indirect_backward, v.direct, true, false + | Forward _ -> v.forward, v.direct, v.indirect_backward, true in v.callstack_length <- min v.callstack_length len; v.direct <- dir; @@ -327,21 +338,21 @@ found, already with Not_found -> let dir, up, down = match kind with - | Direct -> true, false, false - | Indirect_Backward -> false, true, false - | Forward _ -> false, false, true + | Direct -> true, false, false + | Indirect_Backward -> false, true, false + | Forward _ -> false, false, true in let v = - { pdg = pdg; callstack_length = len; - direct = dir; indirect_backward = up; forward = down } + { pdg = pdg; callstack_length = len; + direct = dir; indirect_backward = up; forward = down } in false, if first && kind = Forward Impact then - ( do not add the initial selected stmt for an impact analysis. - fixed FS#411 ) - already + ( do not add the initial selected stmt for an impact analysis. + fixed FS#411 ) + already else - M.add elt v already + M.add elt v already let one_step_related_nodes kind pdg node = ( do not consider address dependencies now (except for impact analysis): @@ -352,18 +363,20 @@ | Direct -> direct node | Indirect_Backward -> direct node @ !Pdg.direct_ctrl_dpds pdg node | Forward Security -> - !Pdg.direct_data_uses pdg node @ !Pdg.direct_ctrl_uses pdg node + !Pdg.direct_data_uses pdg node @ !Pdg.direct_ctrl_uses pdg node | Forward Impact -> - !Pdg.direct_data_uses pdg node @ !Pdg.direct_ctrl_uses pdg node - @ !Pdg.direct_addr_uses pdg node + !Pdg.direct_data_uses pdg node @ !Pdg.direct_ctrl_uses pdg node + @ !Pdg.direct_addr_uses pdg node let search_input kind kf lazy_l = try match kind with | Forward _ -> Lazy.force lazy_l | Direct | Indirect_Backward -> - if Kernel_function.is_definition kf then [] else Lazy.force lazy_l - with Pdg.NotFound -> + if !Db.Value.use_spec_instead_of_definition kf + then Lazy.force lazy_l + else [] + with Not_found -> [] let add_from_deep caller todo n = @@ -373,19 +386,19 @@ let pdg = !Pdg.get kf in List.fold_left (fun todolist (caller, callsites) -> - (* foreach caller ) - List.fold_left - (fun todolist callsite -> - let nodes = - !Pdg.find_call_out_nodes_to_select - pdg [ node ] (!Pdg.get caller) callsite - in - List.fold_left - (add_from_deep caller) - todolist - nodes) - todolist - callsites) + ( foreach caller ) + List.fold_left + (fun todolist callsite -> + let nodes = + !Pdg.find_call_out_nodes_to_select + pdg [ node ] (!Pdg.get caller) callsite + in + List.fold_left + (add_from_deep caller) + todolist + nodes) + todolist + callsites) todolist (!Value.callers kf) @@ -396,200 +409,217 @@ let rec aux first result = function | [] -> result | { Todolist.node = node; kf = kf; pdg = pdg; - callstack_length = callstack_length; from_deep = from_deep } - :: todolist - -> - let elt = node, kf in - let found, result = - check_and_add first elt kind pdg callstack_length result - in - let todolist = - if found then begin - todolist - end else begin - Security_slicing_parameters.debug - ~level:2 "considering node %a (in %s)" - (!Pdg.pretty_node false) node - (Kernel_function.get_name kf); - ( intraprocedural related_nodes ) - let related_nodes = one_step_related_nodes kind pdg node in - Security_slicing_parameters.debug ~level:3 - "intraprocedural part done"; - let todolist = - List.fold_left - (fun todo n -> - Todolist.add n kf pdg callstack_length false todo) - todolist - related_nodes - in - ( interprocedural part ) - let backward_from_deep compute_nodes = - ( [TODO optimisation:] - en fait, regarder from_deep: - si vrai, faire pour chaque caller - sinon, faire uniquement pour le caller d'o� on vient ) - match kind, callstack_length with - | (Direct | Indirect_Backward), 0 -> - ( input of a deep security annotation: foreach call - to [kf], compute its related nodes ) - let do_caller todolist (caller, callsites) = - ( Format.printf "[security of %s] search callers in %s - for zone %a@." (Kernel_function.get_name kf) - (Kernel_function.get_name caller) - Locations.Zone.pretty zone;) - let pdg_caller = !Pdg.get caller in - let do_call todolist callsite = - match kind with - | Direct | Indirect_Backward -> - let nodes = compute_nodes pdg_caller callsite in - List.fold_left - (add_from_deep caller) todolist nodes - | Forward _ -> - todolist ( not considered here, see at end ) - in - List.fold_left do_call todolist callsites - in - List.fold_left do_caller todolist (!Value.callers kf) - | _ -> - todolist - in - let todolist = - match !Pdg.node_key node with - | Key.SigKey (Signature.In Signature.InCtrl) -> - assert false - | Key.SigKey (Signature.In (Signature.InImpl zone)) -> - let compute_nodes pdg_caller callsite = + callstack_length = callstack_length; from_deep = from_deep } + :: todolist + -> + let elt = node, kf in + let found, result = + check_and_add first elt kind pdg callstack_length result + in + let todolist = + if found then begin + todolist + end else begin + Security_slicing_parameters.debug + ~level:2 "considering node %a (in %s)" + (!Pdg.pretty_node false) node + (Kernel_function.get_name kf); + ( intraprocedural related_nodes ) + let related_nodes = one_step_related_nodes kind pdg node in + Security_slicing_parameters.debug ~level:3 + "intraprocedural part done"; + let todolist = + List.fold_left + (fun todo n -> + Todolist.add n kf pdg callstack_length false todo) + todolist + related_nodes + in + ( interprocedural part ) + let backward_from_deep compute_nodes = + ( [TODO optimisation:] + en fait, regarder from_deep: + si vrai, faire pour chaque caller + sinon, faire uniquement pour le caller d'o� on vient ) + match kind, callstack_length with + | (Direct | Indirect_Backward), 0 -> + ( input of a deep security annotation: foreach call + to [kf], compute its related nodes ) + let do_caller todolist (caller, callsites) = + ( Format.printf "[security of %s] search callers in %s + for zone %a@." (Kernel_function.get_name kf) + (Kernel_function.get_name caller) + Locations.Zone.pretty zone;) + let pdg_caller = !Pdg.get caller in + let do_call todolist callsite = + match kind with + | Direct | Indirect_Backward -> + let nodes = compute_nodes pdg_caller callsite in + List.fold_left + (add_from_deep caller) todolist nodes + | Forward _ -> + todolist ( not considered here, see at end ) + in + List.fold_left do_call todolist callsites + in + List.fold_left do_caller todolist (!Value.callers kf) + | _ -> + todolist + in + let todolist = + match !Pdg.node_key node with + | Key.SigKey (Signature.In Signature.InCtrl) -> + assert false + | Key.SigKey (Signature.In (Signature.InImpl zone)) -> + let compute_nodes pdg_caller callsite = let nodes, _undef_zone = - !Pdg.find_location_nodes_at_stmt - pdg_caller callsite ~before:true zone + !Pdg.find_location_nodes_at_stmt + pdg_caller callsite ~before:true zone ( TODO : use undef_zone (see FS#201)? ) in let nodes = List.map (fun (n, _z_part) -> n) nodes in ( TODO : use _z_part ? ) - nodes - in - backward_from_deep compute_nodes - | Key.SigKey key -> - let compute_nodes pdg_caller callsite = - [ match key with - | Signature.In (Signature.InNum n) -> - !Pdg.find_call_input_node pdg_caller callsite n - | Signature.Out Signature.OutRet -> - !Pdg.find_call_output_node pdg_caller callsite - | Signature.In - (Signature.InCtrl | Signature.InImpl _) - | Signature.Out _ -> - assert false ] - in - backward_from_deep compute_nodes - | Key.SigCallKey(id, key) -> - ( the node is a call: search the related nodes inside the - called function (see FS#155) ) - if from_deep then - ( already come from a deeper annotation: - do not go again inside it ) - todolist - else - let stmt = Key.call_from_id id in - let called_kfs = - Kernel_function.Hptset.elements - (try Value.call_to_kernel_function stmt - with Value.Not_a_call -> assert false) - in - let todolist = - List.fold_left - (fun todolist called_kf -> - ( foreach called kf ) - (Format.printf - "[security] search inside %s (from %s)@." - (Kernel_function.get_name called_kf) - (Kernel_function.get_name kf);) - let called_pdg = !Pdg.get called_kf in - let nodes = match kind, key with - | (Direct | Indirect_Backward), - Signature.Out out_key -> - let nodes, _undef_zone = - !Pdg.find_output_nodes called_pdg out_key - ( TODO: use undef_zone (see FS#201) ) - in - let nodes = - List.map (fun (n, _z_part) -> n) nodes in + nodes + in + backward_from_deep compute_nodes + | Key.SigKey key -> + let compute_nodes pdg_caller callsite = + [ match key with + | Signature.In (Signature.InNum n) -> + !Pdg.find_call_input_node pdg_caller callsite n + | Signature.Out Signature.OutRet -> + !Pdg.find_call_output_node pdg_caller callsite + | Signature.In + (Signature.InCtrl | Signature.InImpl _) + | Signature.Out _ -> + assert false ] + in + backward_from_deep compute_nodes + | Key.SigCallKey(id, key) -> + ( the node is a call: search the related nodes inside the + called function (see FS#155) ) + if from_deep then + ( already come from a deeper annotation: + do not go again inside it ) + todolist + else + let stmt = Key.call_from_id id in + let called_kfs = + Kernel_function.Hptset.elements + (try Value.call_to_kernel_function stmt + with Value.Not_a_call -> assert false) + in + let todolist = + List.fold_left + (fun todolist called_kf -> + ( foreach called kf ) + (Format.printf + "[security] search inside %s (from %s)@." + (Kernel_function.get_name called_kf) + (Kernel_function.get_name kf);) + let called_pdg = !Pdg.get called_kf in + let nodes = + try + match kind, key with + | (Direct | Indirect_Backward), + Signature.Out out_key -> + let nodes, _undef_zone = + !Pdg.find_output_nodes called_pdg out_key + ( TODO: use undef_zone (see FS#201) ) + in + let nodes = + List.map (fun (n, _z_part) -> n) nodes in ( TODO : use _z_part ? ) - nodes - | _, Signature.In (Signature.InNum n) -> - search_input kind called_kf - (lazy [!Pdg.find_input_node called_pdg n]) - | _, Signature.In Signature.InCtrl -> - search_input kind called_kf - (lazy - [!Pdg.find_entry_point_node called_pdg]) - | _, Signature.In (Signature.InImpl _) -> - assert false - | Forward _, Signature.Out _ -> - [] - in - List.fold_left - (fun todo n -> - (Format.printf "node %a inside %s@." - (!Pdg.pretty_node false) n - (Kernel_function.get_name called_kf);) - Todolist.add - n called_kf called_pdg - (callstack_length + 1) false todo) - todolist - nodes) - todolist - called_kfs - in - (match kind with - | Direct | Indirect_Backward -> - todolist - | Forward _ -> - List.fold_left - (fun todolist called_kf -> - let compute_from_stmt fold = - fold - (fun (n, kfn) _ acc -> - if kfn == kf then n :: acc else acc) - in - let from_stmt = - compute_from_stmt M.fold result [] in - let from_stmt = - ( initial nodes may be not in results ) - compute_from_stmt - (fun f e acc -> - List.fold_left - (fun acc e -> f e [] acc) acc e) - initial_nodes - from_stmt - in - let called_pdg = !Pdg.get called_kf in - let nodes = - !Pdg.find_in_nodes_to_select_for_this_call - pdg from_stmt stmt called_pdg - in - List.fold_left - (fun todo n -> - Todolist.add - n called_kf called_pdg - (callstack_length + 1) false todo) - todolist - nodes) - todolist - called_kfs) - | Key.CallStmt _ | Key.VarDecl _ -> - assert false - | Key.Stmt _ | Key.Label _ -> - todolist - in - ( [TODO optimisation:] voir commentaire plus haut ) - match kind with - | (Direct | Indirect_Backward) -> todolist - | Forward _ -> forward_caller kf node todolist - end - in - ( recursive call ) - aux false result todolist + nodes + | _, Signature.In (Signature.InNum n) -> + search_input kind called_kf + (lazy [!Pdg.find_input_node called_pdg n]) + | _, Signature.In Signature.InCtrl -> + search_input kind called_kf + (lazy + [!Pdg.find_entry_point_node called_pdg]) + | _, Signature.In (Signature.InImpl _) -> + assert false + | Forward _, Signature.Out _ -> + [] + with + | Pdg.Top -> + Security_slicing_parameters.warning + "no precise pdg for function %s. \n\ +Ignoring this function in the analysis (potentially incorrect results)." + (Kernel_function.get_name called_kf); + [] + | Pdg.Bottom | Not_found -> assert false + in + List.fold_left + (fun todo n -> + (Format.printf "node %a inside %s@." + (!Pdg.pretty_node false) n + (Kernel_function.get_name called_kf);) + Todolist.add + n called_kf called_pdg + (callstack_length + 1) false todo) + todolist + nodes) + todolist + called_kfs + in + (match kind with + | Direct | Indirect_Backward -> + todolist + | Forward _ -> + List.fold_left + (fun todolist called_kf -> + let compute_from_stmt fold = + fold + (fun (n, kfn) _ acc -> + if Kernel_function.equal kfn kf then n :: acc + else acc) + in + let from_stmt = + compute_from_stmt M.fold result [] in + let from_stmt = + ( initial nodes may be not in results ) + compute_from_stmt + (fun f e acc -> + List.fold_left + (fun acc e -> f e [] acc) acc e) + initial_nodes + from_stmt + in + let called_pdg = !Pdg.get called_kf in + let nodes = + try + !Pdg.find_in_nodes_to_select_for_this_call + pdg from_stmt stmt called_pdg + with + | Pdg.Top -> + ( warning already emited in the previous fold ) + [] + | Pdg.Bottom | Not_found -> assert false + in + List.fold_left + (fun todo n -> + Todolist.add + n called_kf called_pdg + (callstack_length + 1) false todo) + todolist + nodes) + todolist + called_kfs) + | Key.CallStmt _ | Key.VarDecl _ -> + assert false + | Key.Stmt _ | Key.Label _ -> + todolist + in + ( [TODO optimisation:] voir commentaire plus haut ) + match kind with + | (Direct | Indirect_Backward) -> todolist + | Forward _ -> forward_caller kf node todolist + end + in + ( recursive call ) + aux false result todolist in aux true result nodes @@ -599,12 +629,12 @@ let pdg = !Pdg.get kf in let nodes = if Db.Value.is_reachable_stmt stmt then - try !Pdg.find_simple_stmt_nodes pdg stmt - with Pdg.NotFound -> assert false + try !Pdg.find_simple_stmt_nodes pdg stmt + with Not_found -> assert false else begin - Security_slicing_parameters.debug - ~level:3 "stmt %d is dead. skipping." stmt.sid; - [] + Security_slicing_parameters.debug + ~level:3 "stmt %d is dead. skipping." stmt.sid; + [] end in Todolist.mk_init kf pdg nodes @@ -613,18 +643,18 @@ try let nodes = initial_nodes kf stmt in Security_slicing_parameters.debug - "computing direct component %d" stmt.sid; + "computing direct component %d" stmt.sid; let res = related_nodes_of_nodes Direct M.empty nodes in ( add the initial node, fix FS#180 ) let mk p = - { pdg = p; callstack_length = 0; - direct = true; indirect_backward = false; forward = false } + { pdg = p; callstack_length = 0; + direct = true; indirect_backward = false; forward = false } in let res = - List.fold_left - (fun acc { Todolist.node=n; kf=f; pdg=p } -> M.add (n,f) (mk p) acc) - res - nodes + List.fold_left + (fun acc { Todolist.node=n; kf=f; pdg=p } -> M.add (n,f) (mk p) acc) + res + nodes in res with Pdg.Top | Pdg.Bottom -> @@ -636,7 +666,7 @@ let nodes = initial_nodes kf stmt in let res = direct kf stmt in Security_slicing_parameters.debug - "computing backward indirect component for %d" stmt.sid; + "computing backward indirect component for %d" stmt.sid; related_nodes_of_nodes Indirect_Backward res nodes with Pdg.Top | Pdg.Bottom -> Security_slicing_parameters.warning "PDG is not manageable. skipping."; @@ -646,10 +676,10 @@ let res = backward kf stmt in let from = M.fold - (fun (n,kf) v acc -> - Todolist.add n kf v.pdg v.callstack_length false(?) acc) - res - [] + (fun (n,kf) v acc -> + Todolist.add n kf v.pdg v.callstack_length false(?) acc) + res + [] in Security_slicing_parameters.debug "computing forward component for stmt %d" stmt.sid; @@ -663,18 +693,18 @@ let res = related_nodes_of_nodes (Forward fwd_kind) M.empty nodes in let set = M.fold - (fun (n,_) _ acc -> - Extlib.may_map - ~dft:acc - (fun s -> Stmt.Set.add s acc) - (get_node_stmt n)) - res - Stmt.Set.empty + (fun (n,_) _ acc -> + Extlib.may_map + ~dft:acc + (fun s -> Stmt.Set.add s acc) + (get_node_stmt n)) + res + Stmt.Set.empty in Stmt.Set.elements set let get_component kind stmt = - let _, kf = Kernel_function.find_from_sid stmt.sid in + let kf = Kernel_function.find_englobing_kf stmt in let action, check = match kind with | Direct -> direct, is_direct | Indirect_Backward -> backward, is_indirect_backward @@ -682,16 +712,16 @@ in let set = M.fold - (fun (n,_) v acc -> - if check v then - Extlib.may_map - ~dft:acc - (fun s -> Stmt.Set.add s acc) - (get_node_stmt n) - else - acc) - (action kf stmt) - Stmt.Set.empty + (fun (n,_) v acc -> + if check v then + Extlib.may_map + ~dft:acc + (fun s -> Stmt.Set.add s acc) + (get_node_stmt n) + else + acc) + (action kf stmt) + Stmt.Set.empty in Stmt.Set.elements set @@ -749,18 +779,18 @@ (Stmt.Hashtbl) (Datatype.Ref(Datatype.List(Stmt))) (struct - let name = "Components" - let size = 7 - let dependencies = [ Ast.self; Db.Value.self ] + let name = "Components" + let size = 7 + let dependencies = [ Ast.self; Db.Value.self ] let kind = `Internal end) let () = Cmdline.run_after_extended_stage (fun () -> - State_dependency_graph.Static.add_codependencies - ~onto:S.self - [ !Db.Pdg.self ]) + State_dependency_graph.Static.add_codependencies + ~onto:S.self + [ !Db.Pdg.self ]) let add c = let l = S.memo (fun _ -> ref []) c in @@ -793,17 +823,17 @@ (fun () -> search_security_requirements (); let add_component stmt = - Security_slicing_parameters.debug - "computing security component %d" stmt.sid; - let add_one = Components.add stmt in - let kf = snd (Kernel_function.find_from_sid stmt.sid) in - Component.iter - !use_ctrl_dependencies - (fun (n, _ as elt) -> - Nodes.add elt; - Extlib.may add_one (get_node_stmt n)) - kf - stmt + Security_slicing_parameters.debug + "computing security component %d" stmt.sid; + let add_one = Components.add stmt in + let kf = Kernel_function.find_englobing_kf stmt in + Component.iter + !use_ctrl_dependencies + (fun (n, _ as elt) -> + Nodes.add elt; + Extlib.may add_one (get_node_stmt n)) + kf + stmt in Security_Annotations.iter add_component) diff -Nru frama-c-20110201+carbon+dfsg/src/security_slicing/configure frama-c-20111001+nitrogen+dfsg/src/security_slicing/configure --- frama-c-20110201+carbon+dfsg/src/security_slicing/configure 2011-02-07 15:05:33.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/security_slicing/configure 2011-10-10 08:56:40.000000000 +0000 @@ -1,11 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.67. +# Generated by GNU Autoconf 2.65. # # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software -# Foundation, Inc. +# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, +# Inc. # # # This configure script is free software; the Free Software Foundation @@ -315,7 +315,7 @@ 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" + } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" } # as_fn_mkdir_p @@ -355,19 +355,19 @@ fi # as_fn_arith -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- +# as_fn_error 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. +# 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 + as_status=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 fi - $as_echo "$as_me: error: $2" >&2 + $as_echo "$as_me: error: $1" >&2 as_fn_exit $as_status } # as_fn_error @@ -529,7 +529,7 @@ exec 6>&1 # Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` @@ -668,9 +668,8 @@ fi case $ac_option in - =?) ac_optarg=`expr "X$ac_option" : '[^=]=$.$'` ;; - =) ac_optarg= ;; - ) ac_optarg=yes ;; + =) ac_optarg=`expr "X$ac_option" : '[^=]=$.$'` ;; + ) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. @@ -715,7 +714,7 @@ 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" + 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 @@ -741,7 +740,7 @@ 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" + 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 @@ -945,7 +944,7 @@ 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" + 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 @@ -961,7 +960,7 @@ 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" + 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 @@ -991,8 +990,8 @@ | --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" + -) as_fn_error "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information." ;; =) @@ -1000,7 +999,7 @@ # 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'" ;; + as_fn_error "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; @@ -1018,13 +1017,13 @@ if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" + 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" ;; + fatal) as_fn_error "unrecognized options: $ac_unrecognized_opts" ;; ) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi @@ -1047,7 +1046,7 @@ [\\/$] | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in prefix ) continue;; esac;; esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" + 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' @@ -1061,8 +1060,8 @@ if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe - $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used" >&2 + $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi @@ -1077,9 +1076,9 @@ 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" + 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" + as_fn_error "pwd does not report name of working directory" # Find the source files, if location was not specified. @@ -1118,11 +1117,11 @@ 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" + 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" + 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 @@ -1162,7 +1161,7 @@ --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 + -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 @@ -1288,9 +1287,9 @@ if $ac_init_version; then cat <<\_ACEOF configure -generated by GNU Autoconf 2.67 +generated by GNU Autoconf 2.65 -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2009 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF @@ -1305,7 +1304,7 @@ running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was -generated by GNU Autoconf 2.67. Invocation command line was +generated by GNU Autoconf 2.65. Invocation command line was $ $0 $@ @@ -1415,9 +1414,11 @@ { echo - $as_echo "## ---------------- ## + cat <<\_ASBOX +## ---------------- ## ## Cache variables. ## -## ---------------- ##" +## ---------------- ## +_ASBOX echo # The following way of writing the cache mishandles newlines in values, ( @@ -1451,9 +1452,11 @@ ) echo - $as_echo "## ----------------- ## + cat <<\_ASBOX +## ----------------- ## ## Output variables. ## -## ----------------- ##" +## ----------------- ## +_ASBOX echo for ac_var in $ac_subst_vars do @@ -1466,9 +1469,11 @@ echo if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## + cat <<\_ASBOX +## ------------------- ## ## File substitutions. ## -## ------------------- ##" +## ------------------- ## +_ASBOX echo for ac_var in $ac_subst_files do @@ -1482,9 +1487,11 @@ fi if test -s confdefs.h; then - $as_echo "## ----------- ## + cat <<\_ASBOX +## ----------- ## ## confdefs.h. ## -## ----------- ##" +## ----------- ## +_ASBOX echo cat confdefs.h echo @@ -1539,12 +1546,7 @@ 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 + ac_site_file1=$CONFIG_SITE elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site @@ -1559,11 +1561,7 @@ { $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 ; } + . "$ac_site_file" fi done @@ -1639,7 +1637,7 @@ $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 + as_fn_error "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## @@ -1811,7 +1809,7 @@ if test "$short_mark" = "no"; then fp=FORCE_"$up" if eval test "\$$fp" = "yes"; then - as_fn_error $? "$lp requested but $reason." "$LINENO" 5 + as_fn_error "$lp requested but $reason." "$LINENO" 5 else { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $lp disabled because $reason." >&5 $as_echo "$as_me: WARNING: $lp disabled because $reason." >&2;} @@ -2001,7 +1999,7 @@ $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && - as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 + as_fn_error "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "Makefile.in"; then ac_cv_file_Makefile_in=yes else @@ -2050,7 +2048,7 @@ #eval ENABLE_DYNAMIC_$up=\$ENABLE if test "$plugin_present" = "no" -a "$FORCE" = "yes"; then - as_fn_error $? "security_slicing is not available" "$LINENO" 5 + as_fn_error "security_slicing is not available" "$LINENO" 5 fi FORCE_SECURITY_SLICING=$FORCE @@ -2087,7 +2085,9 @@ echo "security_slicing... $ENABLE" - +# kept defined for write_plugin_config. A bit ugly, but not more than +# usual autoconf stuff. +# m4_undefine([PLUGIN_NAME]) @@ -2160,7 +2160,7 @@ - ac_config_files="$ac_config_files ./Makefile" + ac_config_files="$ac_config_files ./Makefile" @@ -2184,7 +2184,7 @@ $as_echo "$as_me: $name: $ep_v$info" >&6;} fi done - cat >confcache <<\_ACEOF + 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. @@ -2303,7 +2303,6 @@ 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$//' @@ -2465,19 +2464,19 @@ (unset CDPATH) >/dev/null 2>&1 && unset CDPATH -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- +# as_fn_error 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. +# 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 + as_status=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 fi - $as_echo "$as_me: error: $2" >&2 + $as_echo "$as_me: error: $1" >&2 as_fn_exit $as_status } # as_fn_error @@ -2673,7 +2672,7 @@ 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" + } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" } # as_fn_mkdir_p @@ -2727,7 +2726,7 @@ # values after options handling. ac_log=" This file was extended by $as_me, which was -generated by GNU Autoconf 2.67. Invocation command line was +generated by GNU Autoconf 2.65. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -2780,10 +2779,10 @@ 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.67, +configured by $0, generated by GNU Autoconf 2.65, with options \\"\$ac_cs_config\\" -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2009 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -2798,16 +2797,11 @@ 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 @@ -2829,7 +2823,6 @@ $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;; @@ -2840,7 +2833,7 @@ ac_cs_silent=: ;; # This is an error. - -) as_fn_error $? "unrecognized option: \`$1' + -) as_fn_error "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; ) as_fn_append ac_config_targets " $1" @@ -2891,7 +2884,7 @@ case $ac_config_target in "./Makefile") CONFIG_FILES="$CONFIG_FILES ./Makefile" ;; - ) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5 ;; + ) as_fn_error "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done @@ -2927,7 +2920,7 @@ { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +} || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. @@ -2944,7 +2937,7 @@ fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' + ac_cs_awk_cr='\r' else ac_cs_awk_cr=$ac_cr fi @@ -2958,18 +2951,18 @@ 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 '^'` + 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 + 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 + as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi @@ -3058,28 +3051,20 @@ else cat fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 + || 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 +# VPATH may cause trouble with some makes, so we remove $(srcdir), +# ${srcdir} and @srcdir@ 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/^:// + ac_vpsub='/^[ ]VPATH[ ]=/{ +s/:\$(srcdir):/:/ +s/:\${srcdir}:/:/ +s/:@srcdir@:/:/ +s/^$[^=]=[ ]$:/\1/ s/:$// -x -s/$=[ ]$./\1/ -G -s/\n// s/^[^=]=[ ]$// }' fi @@ -3097,7 +3082,7 @@ esac case $ac_mode$ac_tag in :[FHL]:);; - :L | :C:) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5 ;; + :L* | :C:) as_fn_error "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]) ac_tag=$ac_tag:$ac_tag.in;; esac @@ -3125,7 +3110,7 @@ [\\/$]) false;; ) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5 ;; + as_fn_error "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'" @@ -3152,7 +3137,7 @@ case $ac_tag in :-:* | :-) cat >"$tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac @@ -3278,22 +3263,22 @@ $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + || as_fn_error "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]datarootdir[ ]:=/p' "$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 +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;} +which seems to be undefined. Please make sure it is defined." >&2;} rm -f "$tmp/stdin" case $ac_file in -) cat "$tmp/out" && rm -f "$tmp/out";; ) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; @@ -3313,7 +3298,7 @@ ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + as_fn_error "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. @@ -3334,7 +3319,7 @@ 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 + $ac_cs_success || as_fn_exit $? 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 diff -Nru frama-c-20110201+carbon+dfsg/src/security_slicing/register_gui.ml frama-c-20111001+nitrogen+dfsg/src/security_slicing/register_gui.ml --- frama-c-20110201+carbon+dfsg/src/security_slicing/register_gui.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/security_slicing/register_gui.ml 2011-10-10 08:38:07.000000000 +0000 @@ -70,12 +70,12 @@ ~callback: (fun () -> ForwardHighlighterState.set - (Components.get_forward_component ki); + (Components.get_forward_component ki); IndirectBackwardHighlighterState.set - (Components.get_indirect_backward_component ki); - DirectHighlighterState.set - (Components.get_direct_component ki); - main_ui#rehighlight ())) + (Components.get_indirect_backward_component ki); + DirectHighlighterState.set + (Components.get_direct_component ki); + main_ui#rehighlight ())) | _ -> () let main main_ui = diff -Nru frama-c-20110201+carbon+dfsg/src/security_slicing/security_slicing_parameters.ml frama-c-20111001+nitrogen+dfsg/src/security_slicing/security_slicing_parameters.ml --- frama-c-20110201+carbon+dfsg/src/security_slicing/security_slicing_parameters.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/security_slicing/security_slicing_parameters.ml 2011-10-10 08:38:07.000000000 +0000 @@ -38,6 +38,6 @@ ( Local Variables: -compile-command: "LC_ALL=C make -C ../.." +compile-command: "make -C ../.." End: *) diff -Nru frama-c-20110201+carbon+dfsg/src/security_slicing/security_slicing_parameters.mli frama-c-20111001+nitrogen+dfsg/src/security_slicing/security_slicing_parameters.mli --- frama-c-20110201+carbon+dfsg/src/security_slicing/security_slicing_parameters.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/security_slicing/security_slicing_parameters.mli 2011-10-10 08:38:07.000000000 +0000 @@ -28,11 +28,11 @@ include S -module Slicing: BOOL +module Slicing: Bool (** Perform the security slicing pre-analysis. ) ( Local Variables: -compile-command: "LC_ALL=C make -C ../.." +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/semantic_callgraph/options.mli frama-c-20111001+nitrogen+dfsg/src/semantic_callgraph/options.mli --- frama-c-20110201+carbon+dfsg/src/semantic_callgraph/options.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/semantic_callgraph/options.mli 2011-10-10 08:38:07.000000000 +0000 @@ -23,8 +23,8 @@ include Plugin.S val name: string -module Filename: Plugin.STRING -module InitFunc: Plugin.STRING_SET +module Filename: Plugin.String +module InitFunc: Plugin.String_set ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/semantic_callgraph/register.ml frama-c-20111001+nitrogen+dfsg/src/semantic_callgraph/register.ml --- frama-c-20110201+carbon+dfsg/src/semantic_callgraph/register.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/semantic_callgraph/register.ml 2011-10-10 08:38:07.000000000 +0000 @@ -20,9 +20,6 @@ (* *) (**************************************************************************) -module H = Hashtbl - -open Db_types open Db open Options open Cil_types @@ -37,7 +34,7 @@ how the numbering of varinfo is done internally ) let equal = Kernel_function.equal - let hash kf = H.hash (Kernel_function.get_name kf) + let hash kf = Hashtbl.hash (Kernel_function.get_name kf) let compare kf1 kf2 = if kf1 == kf2 then 0 else @@ -58,13 +55,13 @@ State_builder.Option_ref (Datatype.Make (struct - ( [JS 2010/09/27] do better? ) - include Datatype.Serializable_undefined - type t = SGraph.t - let name = "SGraph" - let reprs = [ SGraph.create () ] - let mem_project = Datatype.never_any_project - end)) + ( [JS 2010/09/27] do better? ) + include Datatype.Serializable_undefined + type t = SGraph.t + let name = "SGraph" + let reprs = [ SGraph.create () ] + let mem_project = Datatype.never_any_project + end)) (struct let name = "SGState" let dependencies = [ Value.self ] @@ -89,11 +86,11 @@ (fun kf -> if !Value.is_called kf then SGraph.add_vertex g kf; List.iter - (fun (caller,call_sites) -> - List.iter - (fun call_site -> SGraph.add_edge_e g (kf,call_site,caller)) - call_sites) - (!Value.callers kf)); + (fun (caller,call_sites) -> + List.iter + (fun call_site -> SGraph.add_edge_e g (kf,call_site,caller)) + call_sites) + (!Value.callers kf)); g) module Service = @@ -109,12 +106,11 @@ [ `Style (if Kernel_function.is_definition v then `Bold else `Dotted) ] - let equal = Kernel_function.equal - let hash = Kernel_function.hash - let entry_point () = - fst - (try Globals.entry_point () - with Globals.No_such_entry_point _ -> assert false) + let equal = Kernel_function.equal + let hash = Kernel_function.hash + let entry_point () = + try Some (fst (Globals.entry_point ())) + with Globals.No_such_entry_point _ -> None end let iter_vertex = SGraph.iter_vertex let iter_succ = SGraph.iter_succ @@ -129,25 +125,30 @@ (struct let name = "SemanticsServicestate" let dependencies = - [ SGState.self; Parameters.MainFunction.self; InitFunc.self ] + [ SGState.self; Kernel.MainFunction.self; InitFunc.self ] let kind = `Internal end) let get_init_funcs () = - let entry_point_name = Parameters.MainFunction.get () in - let init_funcs = - ( entry point is always a root ) - Datatype.String.Set.add entry_point_name (InitFunc.get ()) - in - ( Add the callees of entry point as roots *) - let callees = - let kf = fst (Globals.entry_point ()) in - !Db.Users.get kf - in - Kernel_function.Hptset.fold - (fun kf acc -> Datatype.String.Set.add (Kernel_function.get_name kf) acc) - callees - init_funcs + let init_funcs = InitFunc.get () in + try + let callees = + let kf, _ = Globals.entry_point () in + !Db.Users.get kf + in + (** add the entry point as root ) + let init_funcs = + Datatype.String.Set.add (Kernel.MainFunction.get ()) init_funcs + in + ( add the callees of entry point as roots ) + Kernel_function.Hptset.fold + (fun kf acc -> Datatype.String.Set.add (Kernel_function.get_name kf) acc) + callees + init_funcs + with Globals.No_such_entry_point _ -> + ( always an entry point for the semantic callgraph since value analysis has + been computed. *) + assert false let compute () = feedback "beginning analysis"; @@ -201,18 +202,18 @@ let rec aux kf = if SGraph.mem_vertex cg kf then SGraph.iter_succ - (fun caller -> - if not (V.mem visited caller) then begin - f caller; - V.add visited caller (); - aux caller - end) - cg - kf + (fun caller -> + if not (V.mem visited caller) then begin + f caller; + V.add visited caller (); + aux caller + end) + cg + kf else Options.warning ~once:true - "Function %s not registered in semantic callgraph. Skipped." - (Kernel_function.get_name kf) + "Function %s not registered in semantic callgraph. Skipped." + (Kernel_function.get_name kf) in aux kf diff -Nru frama-c-20110201+carbon+dfsg/src/semantic_callgraph/Semantic_callgraph.mli frama-c-20111001+nitrogen+dfsg/src/semantic_callgraph/Semantic_callgraph.mli --- frama-c-20110201+carbon+dfsg/src/semantic_callgraph/Semantic_callgraph.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/semantic_callgraph/Semantic_callgraph.mli 2011-10-10 08:38:07.000000000 +0000 @@ -24,5 +24,5 @@ (** Semantic callgraph. ) -( No function is directly exported: they are registered in +( No function is directly exported: they are registered in {!Db.Semantic_Callgraph}. ) diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/fct_slice.ml frama-c-20111001+nitrogen+dfsg/src/slicing/fct_slice.ml --- frama-c-20110201+carbon+dfsg/src/slicing/fct_slice.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/fct_slice.ml 2011-10-10 08:38:22.000000000 +0000 @@ -102,7 +102,7 @@ | None, sgn -> None, sgn | Some (None), sgn -> None, sgn | Some (Some f), sgn -> Some f, sgn - with PdgIndex.NotFound -> empty + with Not_found -> empty in (call_id, f, sgn) let get_call_f_called call_id = get_f_called (get_info_call call_id) @@ -308,7 +308,6 @@ val debug_marked_ff : Format.formatter -> T.t_fct_slice -> unit end = struct - module FI = PdgIndex.FctIndex module Marks4Pdg = struct type t = Marks.t_mark @@ -339,7 +338,7 @@ let pdg = M.get_fi_pdg fi in if (PdgTypes.Pdg.is_top pdg) then raise SlicingTypes.NoPdg; let marks = match marks with None -> empty pdg - | Some (pdg, marks) -> (pdg, FI.copy marks) + | Some (pdg, marks) -> (pdg, PdgIndex.FctIndex.copy marks) in let ff = { T.ff_fct = fi ; T.ff_id = ff_num ; T.ff_marks = marks ; T.ff_called_by = [] } in @@ -375,12 +374,12 @@ assert (Db.Pdg.from_same_fun pdg1 pdg2) ; let merge_marks m1 m2 = Marks.merge_marks [m1; m2] in let merge_call_info _c1 _c2 = None in - let fm = FI.merge fm1 fm2 merge_marks merge_call_info in + let fm = PdgIndex.FctIndex.merge fm1 fm2 merge_marks merge_call_info in (pdg1, fm) let get_mark fm node_key = - try FI.find_info (get_marks fm) node_key - with PdgIndex.NotFound -> Marks.bottom_mark + try PdgIndex.FctIndex.find_info (get_marks fm) node_key + with Not_found -> Marks.bottom_mark let get_node_mark ff node_key = let fm = ff.T.ff_marks in get_mark fm node_key @@ -391,13 +390,13 @@ let get_node_marks ff node_key = let fm = ff.T.ff_marks in - FI.find_all (get_marks fm) node_key + PdgIndex.FctIndex.find_all (get_marks fm) node_key - let get_sgn ff = let fm = ff.T.ff_marks in Some (FI.sgn (get_marks fm)) + let get_sgn ff = let fm = ff.T.ff_marks in Some (PdgIndex.FctIndex.sgn (get_marks fm)) let get_all_input_marks fm = let fm = get_marks fm in - let in_marks = Marks.get_all_input_marks (FI.sgn fm) in + let in_marks = Marks.get_all_input_marks (PdgIndex.FctIndex.sgn fm) in let out_marks = [] in (in_marks, out_marks) @@ -589,12 +588,12 @@ let m = Marks.inter_marks dpds_marks in let marks = check_in_params (n+1) params in if not (Marks.is_bottom_mark m) then begin - SlicingParameters.debug ~level:2 - "[Fct_Slice.FctMarks.mark_visible_inputs] %a -> %a" + SlicingKernel.debug ~level:2 + "[Fct_Slice.FctMarks.mark_visible_inputs] %a -> %a" (!Db.Pdg.pretty_node true) node Marks.pretty_mark m; PdgMarks.add_node_to_select marks (node, None) m end else - marks + marks in let new_marks = check_in_params 1 param_list in mark_and_propagate ff_marks ~to_prop new_marks @@ -611,13 +610,13 @@ let m = Marks.inter_marks dpds_marks in if not (Marks.is_bottom_mark m) then begin SlicingParameters.debug ~level:2 - "[Fct_Slice.FctMarks.mark_visible_outputs] %a -> %a" + "[Fct_Slice.FctMarks.mark_visible_outputs] %a -> %a" (!Db.Pdg.pretty_node true) out_node Marks.pretty_mark m; let select = PdgMarks.add_node_to_select [] (out_node, None) m in let to_prop = mark_and_propagate ff_marks select in assert (to_prop = PropMark.empty_to_prop); () end - with PdgIndex.NotFound -> () + with Not_found -> () let debug_ff_marks fmt fm = let pdg, fm = fm in @@ -625,9 +624,9 @@ let node_key = PdgTypes.Node.elem_key node in let m = try - try FI.find_info fm node_key + try PdgIndex.FctIndex.find_info fm node_key with PdgIndex.CallStatement -> assert false - with PdgIndex.NotFound -> Marks.bottom_mark + with Not_found -> Marks.bottom_mark in Format.fprintf fmt "%a : %a@." (!Db.Pdg.pretty_node true) node Marks.pretty_mark m @@ -996,11 +995,11 @@ * have to add some marks, but no new inputs. ) let add_spare_call_inputs called_kf call_info = let (ff_caller, _call) = CallInfo.get_call_id call_info in - SlicingParameters.debug ~level:2 "[slicing] add_spare_call_inputs in %s@." (M.ff_name ff_caller); + SlicingKernel.debug ~level:2 "[slicing] add_spare_call_inputs in %s@." (M.ff_name ff_caller); let sig_call = CallInfo.get_call_sig call_info in let out0, marked_out_zone = Marks.get_marked_out_zone sig_call in let called_in_zone = get_called_needed_input called_kf out0 marked_out_zone in - SlicingParameters.debug ~level:2 "\tneed %a inputs : %a@." Kernel_function.pretty_name called_kf + SlicingKernel.debug ~level:2 "\tneed %a inputs : %a@." Kernel_function.pretty called_kf Locations.Zone.pretty called_in_zone; let needed_nodes, undef = get_call_in_nodes called_kf call_info called_in_zone in @@ -1054,7 +1053,7 @@ if more_inputs then ( [ff] needs too many inputs ) begin - SlicingParameters.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? too many inputs" + SlicingKernel.debug ~level:2 "[Fct_Slice.choose_precise_slice] %s ? too many inputs" (M.ff_name ff); find slices end @@ -1080,7 +1079,7 @@ | [] -> make_new_ff fi_to_call true | ff :: [] -> ff, [] | _ -> ( TODO : choose a slice ) - Extlib.not_yet_implemented "choose_min_slice with several slices" + Extlib.not_yet_implemented "choose_min_slice with several slices" in let choose_full_slice fi_to_call = SlicingParameters.debug ~level:2 "PropagateMarksOnly -> choose_full_slice"; @@ -1120,7 +1119,8 @@ choose_precise_slice fi_to_call call_info in (T.CallSlice ff_to_call), new_filters with SlicingTypes.NoPdg -> - Cil.log "[slicing]unable to compute %s PDG : call source function" + SlicingParameters.feedback + "unable to compute %s PDG : call source function" (M.fi_name fi_to_call); T.CallSrc None, [] in to_call, new_filters @@ -1346,7 +1346,7 @@ let get_node_key_mark ff k = try FctMarks.get_node_mark ff k - with PdgIndex.NotFound -> Marks.bottom_mark + with Not_found -> Marks.bottom_mark let get_node_mark ff node = get_node_key_mark ff (PdgTypes.Node.elem_key node) @@ -1358,7 +1358,7 @@ try match FctMarks.get_sgn ff with None -> Marks.bottom_mark | Some sgn -> Marks.get_input_mark sgn n - with PdgIndex.NotFound -> Marks.bottom_mark + with Not_found -> Marks.bottom_mark let get_label_mark ff label_stmt label = let key = PdgIndex.Key.label_key label_stmt label in @@ -1374,7 +1374,7 @@ | _ -> assert false in Marks.merge_marks marks - with PdgIndex.NotFound -> + with Not_found -> match stmt.Cil_types.skind with | Cil_types.Block _ | Cil_types.UnspecifiedSequence _ -> ( block are always visible for syntactic reasons ) @@ -1385,7 +1385,7 @@ try let key = PdgIndex.Key.top_input in FctMarks.get_fi_node_mark fi key - with PdgIndex.NotFound -> Marks.bottom_mark + with Not_found -> Marks.bottom_mark let merge_inputs_m1_mark ff = let ff_sig = @@ -1413,7 +1413,7 @@ let merge m = acc := merge m !acc ; if is_top !acc then - raise StopMerging ( acceleration when top is reached ) + raise StopMerging ( acceleration when top is reached ) in let rec merge_fun_callers kf = let merge_fun_caller (kf,_) = merge_fun_callers kf in @@ -1423,13 +1423,13 @@ List.iter (fun x -> merge (get_value x)) (get_list proj kf) ; List.iter merge_fun_caller (!Db.Value.callers kf) end - ( else no way to add something, the [kf] contribution is already - accumulated. ) + ( else no way to add something, the [kf] contribution is already + accumulated. *) in - merge_fun_callers kf; + merge_fun_callers kf; !acc with StopMerging -> - !acc + !acc end (** The mark [m] related to all statements of a source function [kf]. @@ -1455,3 +1455,9 @@ | None -> Format.fprintf fmt "<not computed>@." | Some s -> Format.fprintf fmt "%a@." Marks.pretty_sig s (-----------------------------------------------------------------------) + +(* +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/fct_slice.mli frama-c-20111001+nitrogen+dfsg/src/slicing/fct_slice.mli --- frama-c-20110201+carbon+dfsg/src/slicing/fct_slice.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/fct_slice.mli 2011-10-10 08:38:22.000000000 +0000 @@ -32,10 +32,10 @@ because there cannot be any slice for it. * @raise SlicingTypes.NoPdg when there is no PDG for the function. ) -val make_new_ff : SlicingInternals.t_fct_info -> bool -> +val make_new_ff : SlicingInternals.t_fct_info -> bool -> t_fct_slice t_crit list -val merge_slices : t_fct_slice -> t_fct_slice -> +val merge_slices : t_fct_slice -> t_fct_slice -> t_fct_slice * t_crit list val copy_slice : t_fct_slice -> t_fct_slice @@ -44,19 +44,19 @@ SlicingInternals.t_fct_base_criterion -> SlicingInternals.t_fct_base_criterion -val apply_add_marks : +val apply_add_marks : t_fct_slice -> SlicingInternals.t_fct_base_criterion -> t_crit list -val add_marks_to_fi : - SlicingInternals.t_project -> - SlicingInternals.t_fct_info -> +val add_marks_to_fi : + SlicingInternals.t_project -> + SlicingInternals.t_fct_info -> SlicingInternals.t_fct_base_criterion -> bool -> t_crit list -> bool * t_crit list -val add_top_mark_to_fi : - SlicingInternals.t_fct_info -> +val add_top_mark_to_fi : + SlicingInternals.t_fct_info -> SlicingInternals.t_pdg_mark -> bool -> t_crit list -> t_crit list @@ -67,10 +67,10 @@ val apply_change_call : SlicingInternals.t_project -> t_fct_slice -> SlicingInternals.t_call_id -> - SlicingInternals.t_called_fct -> + SlicingInternals.t_called_fct -> t_crit list -val apply_choose_call : SlicingInternals.t_project -> +val apply_choose_call : SlicingInternals.t_project -> t_fct_slice -> SlicingInternals.t_call_id -> t_crit list @@ -78,7 +78,7 @@ t_fct_slice -> SlicingInternals.t_call_id -> (SlicingInternals.t_fct_base_criterion * bool) -> t_crit list - + val apply_missing_outputs : SlicingInternals.t_project -> t_fct_slice -> SlicingInternals.t_call_id -> SlicingInternals.t_fct_base_criterion -> bool -> @@ -88,7 +88,7 @@ t_mark PdgMarks.t_info_called_outputs -> t_crit list -val get_called_slice : +val get_called_slice : t_fct_slice -> SlicingInternals.t_call_id -> (t_fct_slice option * bool) val get_node_mark : t_fct_slice -> PdgTypes.Node.t -> t_mark @@ -100,7 +100,7 @@ val get_param_mark : t_fct_slice -> int -> t_mark val get_local_var_mark : t_fct_slice -> Cil_types.varinfo -> t_mark val get_input_loc_under_mark : t_fct_slice -> Locations.Zone.t -> t_mark - + val get_mark_from_src_fun : SlicingInternals.t_project -> Kernel_function.t -> t_mark val merge_inputs_m1_mark : t_fct_slice -> t_mark diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/printSlice.ml frama-c-20111001+nitrogen+dfsg/src/slicing/printSlice.ml --- frama-c-20110201+carbon+dfsg/src/slicing/printSlice.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/printSlice.ml 2011-10-10 08:38:22.000000000 +0000 @@ -55,7 +55,7 @@ in Format.fprintf fmt "/* sig call : %a /@\n%t" SlicingMarks.pretty_sig sgn print_called - with Db.Pdg.NotFound -> Format.fprintf fmt "/ invisible call /@." + with Not_found -> Format.fprintf fmt "/ invisible call /@." class printerClass optional_ff = object(self) inherit Printer.print () as super @@ -72,7 +72,7 @@ try let m = Fct_slice.get_local_var_mark ff var in SlicingMarks.mark_to_string m - with Db.Pdg.NotFound -> "[---]" + with Not_found -> "[---]" in Format.fprintf fmt "/ %s / %a" str_m @@ -85,7 +85,7 @@ let str_m = try let m = Fct_slice.get_stmt_mark ff stmt in SlicingMarks.mark_to_string m - with Db.Pdg.NotFound -> "[---]" + with Not_found -> "[---]" in if (M.is_call_stmt stmt) then Format.fprintf fmt "%t/ %s /" (str_call_sig ff stmt) str_m diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/register_gui.ml frama-c-20111001+nitrogen+dfsg/src/slicing/register_gui.ml --- frama-c-20110201+carbon+dfsg/src/slicing/register_gui.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/register_gui.ml 2011-10-10 08:38:22.000000000 +0000 @@ -25,16 +25,20 @@ open Cil_types open Cil_datatype -module Enable = - State_builder.Ref +( Show or hide the 'Slicing' column of the gui filetree. ) +let show_column = ref (fun () -> ()) + +( Are results shown? ) +module Enabled = struct + include State_builder.Ref (Datatype.Bool) (struct let name = "Slicing_gui.State" - let dependencies = [] + let dependencies = [!Db.Slicing.self] let kind = `Internal let default () = false end) - +end ( for slicing callback ) let mk_selection fselect = fselect Db.Slicing.Select.empty_selects @@ -56,10 +60,10 @@ !Db.Slicing.Request.apply_all_internal project; if SlicingParameters.Mode.Callers.get () then !Db.Slicing.Slice.remove_uncalled project; - let sliced_project_name = + let sliced_project_name = let postfix = SlicingParameters.ExportedProjectPostfix.get () in if postfix = "" then project_name else (project_name ^ " " ^ postfix) - in + in let new_project = !Db.Slicing.Project.extract sliced_project_name project in @@ -117,7 +121,7 @@ if not (Db.Value.is_computed ()) then begin let tag_style_oblique = Gtk_helper.make_tag main_ui#annot_window#buffer - ~name:"slicing:style oblique" [`STYLE `OBLIQUE ; ] + ~name:"slicing:style oblique" [`STYLE `OBLIQUE ; ] in main_ui#annot_window#buffer#insert "[Slicing] activation requires an execution of a "; @@ -160,16 +164,18 @@ let slicing_selector (popup_factory:GMenu.menu GMenu.factory) (main_ui:Design.main_window_extension_points) ~button localizable = - if (not (Db.Value.is_computed ())) || not (Enable.get ()) + if (not (Db.Value.is_computed ())) || not (Enabled.get ()) then ignore - (popup_factory#add_item "_Slicing ..." - ~callback: - (fun () -> - if (not (Db.Value.is_computed ())) - then gui_compute_values main_ui ; - if Db.Value.is_computed () - then Enable.set true)) + (popup_factory#add_item "Enable _slicing" + ~callback: + (fun () -> + if (not (Db.Value.is_computed ())) + then gui_compute_values main_ui ; + if Db.Value.is_computed () + then (Enabled.set true; + !show_column ()) + )) else let slicing_project = !Db.Slicing.Project.get_project () in if button = 1 then @@ -222,71 +228,71 @@ let add_slicing_item name = add_item slicing_factory name in let mk_slice = gui_mk_slice main_ui in let add_slice_menu kf_opt kf_ki_opt = - (let callback kf = - mk_slice + (let callback kf = + mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for slicing effects of function %a" - Kernel_function.pretty_name kf) + Pretty_utils.sfprintf + "Request for slicing effects of function %a" + Kernel_function.pretty kf) (mk_selection_all !Db.Slicing.Select.select_func_calls_to kf) - in + in add_slicing_item "Slice calls to" kf_opt ~callback); - (let callback kf = + (let callback kf = mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for slicing entrance into function %a" - Kernel_function.pretty_name kf) + Pretty_utils.sfprintf + "Request for slicing entrance into function %a" + Kernel_function.pretty kf) (mk_selection_all !Db.Slicing.Select.select_func_calls_into kf) - in + in add_slicing_item "Slice calls into" kf_opt ~callback); (let callback kf = mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for returned value of function %a" - Kernel_function.pretty_name kf) + Pretty_utils.sfprintf + "Request for returned value of function %a" + Kernel_function.pretty kf) (mk_selection_all !Db.Slicing.Select.select_func_return kf) - in - add_slicing_item "Slice result" + in + add_slicing_item "Slice result" (Extlib.opt_filter - (fun kf -> - let is_not_void_kf x = + (fun kf -> + let is_not_void_kf x = match x.Cil_types.vtype with | Cil_types.TFun (Cil_types.TVoid (_),_,_,_) -> false | _ -> true - in is_not_void_kf (Kernel_function.get_vi kf)) + in is_not_void_kf (Kernel_function.get_vi kf)) kf_opt) ~callback); - (let callback (kf, ki) = + (let callback (kf, ki) = mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for slicing effects of statement %d" + Pretty_utils.sfprintf + "Request for slicing effects of statement %d" ki.sid) (mk_selection_all !Db.Slicing.Select.select_stmt ki kf) - in + in add_slicing_item "Slice stmt" kf_ki_opt ~callback); - (let callback (kf, ki) = + (let callback (kf, ki) = let do_with_txt txt = try let lval_str = - Datatype.String.Set.add txt Datatype.String.Set.empty - in + Datatype.String.Set.add txt Datatype.String.Set.empty + in mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for slicing Lvalue %s before statement %d" + Pretty_utils.sfprintf + "Request for slicing Lvalue %s before statement %d" txt ki.sid) (mk_selection_cad !Db.Slicing.Select.select_stmt_lval lval_str ~before:true ki ~scope:ki ~eval:ki kf) with e -> - main_ui#error "Invalid expression: %s" (Printexc.to_string e) + main_ui#error "Invalid expression: %s" (Printexc.to_string e) in let txt = GToolbox.input_string @@ -294,91 +300,91 @@ statement" "" in - Extlib.may do_with_txt txt - in + Extlib.may do_with_txt txt + in add_slicing_item "Slice lval" kf_ki_opt ~callback); - (let callback (kf, ki) = + (let callback (kf, ki) = let do_with_txt txt = try let lval_str = - Datatype.String.Set.add txt Datatype.String.Set.empty - in + Datatype.String.Set.add txt Datatype.String.Set.empty + in mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for slicing read accesses to Lvalue %s" + Pretty_utils.sfprintf + "Request for slicing read accesses to Lvalue %s" txt) (mk_selection_cad - !Db.Slicing.Select.select_func_lval_rw + !Db.Slicing.Select.select_func_lval_rw ~rd:lval_str - ~wr:Datatype.String.Set.empty - ~scope:ki - ~eval:ki kf) + ~wr:Datatype.String.Set.empty + ~scope:ki + ~eval:ki kf) with e -> - main_ui#error "Invalid expression: %s" (Printexc.to_string e) + main_ui#error "Invalid expression: %s" (Printexc.to_string e) in let txt = GToolbox.input_string ~title:"Input a pure Lvalue expression to slice read accesses" "" in - Extlib.may do_with_txt txt - in + Extlib.may do_with_txt txt + in add_slicing_item "Slice rd" kf_ki_opt ~callback); - (let callback (kf, ki) = + (let callback (kf, ki) = let do_with_txt txt = try let lval_str = - Datatype.String.Set.add txt Datatype.String.Set.empty - in + Datatype.String.Set.add txt Datatype.String.Set.empty + in mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for slicing writen accesses to Lvalue %s" + Pretty_utils.sfprintf + "Request for slicing writen accesses to Lvalue %s" txt) (mk_selection_cad - !Db.Slicing.Select.select_func_lval_rw + !Db.Slicing.Select.select_func_lval_rw ~rd:Datatype.String.Set.empty - ~wr:lval_str - ~scope:ki - ~eval:ki kf) + ~wr:lval_str + ~scope:ki + ~eval:ki kf) with e -> - main_ui#error "Invalid expression: %s" (Printexc.to_string e) + main_ui#error "Invalid expression: %s" (Printexc.to_string e) in let txt = GToolbox.input_string ~title:"Input a pure Lvalue expression to slice read accesses" "" in - Extlib.may do_with_txt txt - in + Extlib.may do_with_txt txt + in add_slicing_item "Slice wr" kf_ki_opt ~callback); - let callback (kf, ki) = + let callback (kf, ki) = mk_slice ~info:(fun () -> - Pretty_utils.sfprintf - "Request for slicing accessibility to statement %d" + Pretty_utils.sfprintf + "Request for slicing accessibility to statement %d" ki.sid) (mk_selection_all !Db.Slicing.Select.select_stmt_ctrl ki kf) - in + in add_slicing_item "Slice ctrl" kf_ki_opt ~callback in let some_kf_from_vi vi = - try let kf = Globals.Functions.get vi in - if Enable.get () && !Db.Value.is_called kf then Some kf else None + try let kf = Globals.Functions.get vi in + if Enabled.get () && !Db.Value.is_called kf then Some kf else None with Not_found -> None in let some_kf_from_lv lv = match lv with | Var vi,_ -> some_kf_from_vi vi | _ -> None in - let some_kf_ki kf ki = - if Enable.get () + let some_kf_ki kf stmt = + if Enabled.get () && !Db.Value.is_called kf - && Db.Value.is_accessible (Cil_types.Kstmt ki) - then Some (kf, ki) else None in + && Db.Value.is_reachable_stmt stmt + then Some (kf, stmt) else None in begin ( add menu for slicing and scope plug-in ) match localizable with | Pretty_source.PLval (Some kf,(Kstmt stmt),lv) -> @@ -395,7 +401,7 @@ ignore (slicing_factory#add_separator ()); add_slicing_item "_Disable" (Some ()) - ~callback:(fun () -> Enable.set false); + ~callback:(fun () -> Enabled.set false); add_slicing_item "_Clear" (if slicing_project = None then None else Some ()) ~callback:(fun () -> gui_set_project main_ui None) ; @@ -414,33 +420,33 @@ let slicing_highlighter (buffer:GSourceView2.source_buffer) localizable ~start ~stop = - if Enable.get () then begin + if Enabled.get () then begin ( Definition for highlight 'Slicing' ) let highlight project = let ki = Pretty_source.ki_of_localizable localizable in if Db.Value.is_accessible ki then let unused_code_area = - Gtk_helper.make_tag buffer + Gtk_helper.make_tag buffer ~name:"slicing_unused" [`STRIKETHROUGH true ] in let spare_code_area = - Gtk_helper.make_tag buffer ~name:"slicing_spare" [`UNDERLINE `LOW] in + Gtk_helper.make_tag buffer ~name:"slicing_spare" [`UNDERLINE `LOW] in let necessary_code_area = - Gtk_helper.make_tag buffer + Gtk_helper.make_tag buffer ~name:"slicing_necessary" [`BACKGROUND "green"] in let apply_on_one_project_and_merge_slices kf pb pe mark_of_slice = let apply_mark mark = - if SlicingParameters.debug_atleast 1 then - SlicingParameters.debug "Got mark: %a" + if SlicingParameters.debug_atleast 1 then + SlicingParameters.debug "Got mark: %a" !Db.Slicing.Mark.pretty mark; if !Db.Slicing.Mark.is_bottom mark then Gtk_helper.apply_tag buffer unused_code_area pb pe; if !Db.Slicing.Mark.is_spare mark then Gtk_helper.apply_tag buffer spare_code_area pb pe; if (!Db.Slicing.Mark.is_ctrl mark - || !Db.Slicing.Mark.is_data mark - || !Db.Slicing.Mark.is_addr mark) + || !Db.Slicing.Mark.is_data mark + || !Db.Slicing.Mark.is_addr mark) then Gtk_helper.apply_tag buffer necessary_code_area pb pe in @@ -475,20 +481,20 @@ end in let tag_stmt kf stmt pb pe = - assert (Db.Value.is_accessible (Kstmt stmt)) ; + assert (Db.Value.is_reachable_stmt stmt) ; apply_on_one_project_and_merge_slices - kf - pb - pe - (fun _ slice -> !Db.Slicing.Slice.get_mark_from_stmt slice stmt) + kf + pb + pe + (fun _ slice -> !Db.Slicing.Slice.get_mark_from_stmt slice stmt) in let tag_vdecl kf vi pb pe = if not vi.vglob then - apply_on_one_project_and_merge_slices - kf - pb - pe - (fun _ slice -> !Db.Slicing.Slice.get_mark_from_local_var slice vi) + apply_on_one_project_and_merge_slices + kf + pb + pe + (fun _ slice -> !Db.Slicing.Slice.get_mark_from_local_var slice vi) in match localizable with | Pretty_source.PStmt (kf,stmt) -> tag_stmt kf stmt start stop @@ -496,7 +502,7 @@ | Pretty_source.PVDecl (None,_) | Pretty_source.PLval _ | Pretty_source.PTermLval _ - | Pretty_source.PGlobal _ + | Pretty_source.PGlobal _ | Pretty_source.PIP _ -> () in let slicing_project = !Db.Slicing.Project.get_project () in @@ -590,26 +596,27 @@ let hbox2 = GPack.hbox ~packing:(table#attach ~left:1 ~top:0) () in ( [enabled_button] to give slicing menu available ) - let enable_refresh () = - gui_compute_values main_ui ; - main_ui#rehighlight () + let do_refresh to_enable = + if to_enable then gui_compute_values main_ui; + !show_column (); + main_ui#rehighlight (); in let enabled_button = let b = GButton.check_button ~label:"Enable" - ~active:(Enable.get ()) + ~active:(Enabled.get ()) ~packing:(table#attach ~left:0 ~top:0) () in main_ui#help_message b "%s" msg_help_enable_gui ; ignore (b#connect#toggled ~callback:(fun () -> - Enable.set b#active; - enable_refresh ())); + Enabled.set b#active; + do_refresh b#active)); b in let verbose_refresh = Gtk_helper.on_int ~lower:0 ~upper:3 hbox2 "Verbosity" - ~sensitive:Enable.get + ~sensitive:Enabled.get SlicingParameters.Verbose.get (gui_set_slicing_debug main_ui) in @@ -618,7 +625,7 @@ let slice_undef_button = let b = GButton.check_button ~label:"Libraries" - ~active:(Enable.get ()) + ~active:(Enabled.get ()) ~packing:(table#attach ~left:0 ~top:1) () in main_ui#help_message b "%s" msg_help_libraries ; ignore (b#connect#toggled @@ -629,7 +636,7 @@ let level_refresh = Gtk_helper.on_int ~lower:0 ~upper:3 hbox3 "Level" - ~sensitive:Enable.get + ~sensitive:Enabled.get SlicingParameters.Mode.Calls.get (gui_set_slicing_level main_ui) in @@ -640,50 +647,49 @@ let refresh () = let value_is_computed = Db.Value.is_computed () in let slicing_project = !Db.Slicing.Project.get_project () in - let enabled = Enable.get () in + let enabled = Enabled.get () in activate_button#misc#set_sensitive (not value_is_computed) ; enabled_button#misc#set_sensitive value_is_computed ; slice_undef_button#misc#set_sensitive enabled ; - verbose_refresh (); level_refresh (); - - if enabled_button#active <> enabled then - begin - enabled_button#set_active enabled ; - enable_refresh (); - end; - + if Enabled.get () <> enabled_button#active then ( + enabled_button#set_active (Enabled.get ()); + !show_column (); + ); slice_undef_button#set_active (SlicingParameters.Mode.SliceUndef.get()); - - ignore (refresh_combo_box combo_box_text slicing_project (enabled && value_is_computed)) + refresh_combo_box combo_box_text slicing_project + (enabled && value_is_computed) in refresh () ; "Slicing",w#coerce,Some refresh let file_tree_decorate (file_tree:Filetree.t) = - file_tree#append_pixbuf_column - "Slicing" - (fun globs -> - Extlib.may_map - (fun project -> + show_column := + file_tree#append_pixbuf_column + ~title:"Slicing" + (fun globs -> + Extlib.may_map + (fun project -> if (List.exists (fun glob -> match glob with - | GFun ({svar = vi},_ ) -> - begin - try - let kf = Globals.Functions.get vi - in (!Db.Slicing.Project.is_called project kf) - || ( [] != (!Db.Slicing.Slice.get_all project kf)) - with Not_found -> false - end - | _ -> false) + | GFun ({svar = vi},_ ) -> + begin + try + let kf = Globals.Functions.get vi + in (!Db.Slicing.Project.is_called project kf) + || ( [] != (!Db.Slicing.Slice.get_all project kf)) + with Not_found -> false + end + | _ -> false) globs) then [`STOCK_ID "gtk-apply"] else [`STOCK_ID ""]) - ~dft:[`STOCK_ID ""] - (!Db.Slicing.Project.get_project ())) + ~dft:[`STOCK_ID ""] + (!Db.Slicing.Project.get_project ())) + (fun () -> Enabled.get ()); + !show_column () let main (main_ui:Design.main_window_extension_points) = main_ui#register_source_selector slicing_selector; diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/register_gui.mli frama-c-20111001+nitrogen+dfsg/src/slicing/register_gui.mli --- frama-c-20110201+carbon+dfsg/src/slicing/register_gui.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/register_gui.mli 2011-10-10 08:38:22.000000000 +0000 @@ -32,4 +32,3 @@ compile-command: "LC_ALL=C make -C ../.. -j" End: ) - diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/register.ml frama-c-20111001+nitrogen+dfsg/src/slicing/register.ml --- frama-c-20110201+carbon+dfsg/src/slicing/register.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/register.ml 2011-10-10 08:38:22.000000000 +0000 @@ -50,16 +50,16 @@ let print_select fmt db_select = let db_fvar, select = db_select in Format.fprintf fmt "In %a : %a@." - Ast_info.pretty_vname db_fvar Act.print_f_crit select + Varinfo.pretty_vname db_fvar Act.print_f_crit select let get_select_kf (fvar, _select) = Globals.Functions.get fvar let check_db_select fvar db_select = let db_fvar, select = db_select in - if db_fvar.vid <> fvar.vid then + if not (Cil_datatype.Varinfo.equal db_fvar fvar) then begin SlicingParameters.debug - "slice name = %s <> select = %a@." + "slice name = %s <> select = %a@." (fvar.vname) print_select db_select ; raise (Invalid_argument "This selection doesn't belong to the given function"); @@ -73,7 +73,8 @@ let check_ff_db_select ff = check_db_select (M.ff_svar ff) let bottom_msg kf = - Cil.log "[slicing] bottom PDG for function '%s': ignore selection" + SlicingParameters.feedback + "bottom PDG for function '%s': ignore selection" (Kernel_function.get_name kf) let basic_add_select kf select nodes ?(undef) nd_marks = @@ -125,9 +126,9 @@ let sel = mk_select pdg sel nodes undef mark in (fvar, sel) with - | Db.Pdg.NotFound -> (* stmt probably unreachable ) - SlicingParameters.debug - "@[Nothing to select for @[%a@]@ %s stmt %d@]" + | Not_found -> ( stmt probably unreachable ) + SlicingParameters.debug + "@[Nothing to select for @[%a@]@ %s stmt %d@]" Locations.Zone.pretty loc (if before then "before" else "after") stmt.sid ; select @@ -141,7 +142,7 @@ SlicingParameters.debug "[Register.select_in_out_zone] select zone %a (m=%a) at %s of %a" Locations.Zone.pretty loc SlicingMarks.pretty_mark mark - (if at_end then "end" else "begin") Kernel_function.pretty_name kf; + (if at_end then "end" else "begin") Kernel_function.pretty kf; let fvar, sel = check_kf_db_select kf select in match sel with | T.CuTop _ -> select @@ -156,7 +157,7 @@ let sel = mk_select pdg sel nodes undef mark in (fvar, sel) with - | Db.Pdg.NotFound -> assert false + | Not_found -> assert false | Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; select @@ -171,7 +172,7 @@ let stmt_nodes_to_select pdg stmt = let stmt_nodes = - try !Db.Pdg.find_stmt_and_blocks_nodes pdg stmt with Db.Pdg.NotFound -> [] + try !Db.Pdg.find_stmt_and_blocks_nodes pdg stmt with Not_found -> [] in ( TODO : add this when visibility of anotations are ok let stmt_nodes = @@ -235,7 +236,7 @@ let select_entry_point kf ?(select=empty_db_select kf) mark = SlicingParameters.debug ~level:1 "[Register.select_entry_point] of %a" - Kernel_function.pretty_name kf; + Kernel_function.pretty kf; try let pdg = !Db.Pdg.get kf in let node = !Db.Pdg.find_entry_point_node pdg in @@ -246,20 +247,20 @@ let select_return kf ?(select=empty_db_select kf) mark = SlicingParameters.debug ~level:1 "[Register.select_return] of %a" - Kernel_function.pretty_name kf; + Kernel_function.pretty kf; try let pdg = !Db.Pdg.get kf in let node = !Db.Pdg.find_ret_output_node pdg in let nd_marks = Act.build_simple_node_selection mark in basic_add_select kf select [node] nd_marks with - | Db.Pdg.NotFound -> (* unreachable ? ) select + | Not_found -> ( unreachable ? ) select | Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf let select_decl_var kf ?(select=empty_db_select kf) vi mark = SlicingParameters.debug ~level:1 "[Register.select_decl_var] of %s in %a@." - vi.Cil_types.vname Kernel_function.pretty_name kf; + vi.Cil_types.vname Kernel_function.pretty kf; if vi.Cil_types.vglob ( no slicing request on globals ) then select else try @@ -268,7 +269,7 @@ let nd_marks = Act.build_simple_node_selection mark in basic_add_select kf select [node] nd_marks with - | Db.Pdg.NotFound -> ( unreachable ? ) select + | Not_found -> ( unreachable ? *) select | Db.Pdg.Top -> top_db_select kf mark | Db.Pdg.Bottom -> bottom_msg kf; empty_db_select kf @@ -295,13 +296,13 @@ let add_to_selects db_select set = let vf, select = db_select in let select = - try merge_select (SlicingTypes.Sl_selects.find vf set) select + try merge_select (Cil_datatype.Varinfo.Map.find vf set) select with Not_found -> select in - SlicingTypes.Sl_selects.add vf select set + Cil_datatype.Varinfo.Map.add vf select set let iter_selects_internal f set = - SlicingTypes.Sl_selects.iter (fun v sel -> f (v, sel)) set + Cil_datatype.Varinfo.Map.iter (fun v sel -> f (v, sel)) set end @@ -404,7 +405,7 @@ let param_list = Kernel_function.get_formals kf in let rec find n var_list = match var_list with | [] -> raise Not_found - | v :: var_list -> if v.vid = var.vid then n + | v :: var_list -> if Cil_datatype.Varinfo.equal v var then n else find (n+1) var_list in let n = find 1 param_list in Fct_slice.get_param_mark ff n @@ -418,7 +419,7 @@ | Instr (Call (_,expr_f,_,_)) -> if snd (Fct_slice.get_called_slice ff stmt) then Kernel_function.Hptset.elements - (snd (!Db.Value.expr_to_kernel_function + (snd (!Db.Value.expr_to_kernel_function (Kstmt stmt) ~with_alarms:CilE.warn_none_mode ~deps:None @@ -530,9 +531,9 @@ "!Db.Slicing.Project.extract" (Datatype.func3 ~label1:("f_slice_names", - Some (fun () -> !Db.Slicing.Project.default_slice_names)) + Some (fun () -> !Db.Slicing.Project.default_slice_names)) (Datatype.func3 - Kernel_function.ty Datatype.bool Datatype.int Datatype.string) + Kernel_function.ty Datatype.bool Datatype.int Datatype.string) Datatype.string Db.Slicing.Project.dyn_t Project.ty) @@ -590,7 +591,7 @@ ~label3:("rd", None) Datatype.String.Set.ty ~label4:("wr", None) Datatype.String.Set.ty (Datatype.func4 - Stmt.ty + Stmt.ty ~label2:("scope", None) Stmt.ty ~label3:("eval", None) Stmt.ty Kernel_function.ty @@ -610,7 +611,7 @@ Datatype.String.Set.ty ~label4:("before", None) Datatype.bool (Datatype.func4 - Stmt.ty + Stmt.ty ~label2:("scope", None) Stmt.ty ~label3:("eval", None) Stmt.ty Kernel_function.ty @@ -630,12 +631,12 @@ ~label3:("spare", None) Datatype.bool ~label4:("ai", None) Datatype.bool (Datatype.func4 - ~label1:("user_assert", None) Datatype.bool + ~label1:("user_assert", None) Datatype.bool ~label2:("slicing_pragma", None) Datatype.bool ~label3:("loop_inv", None) Datatype.bool ~label4:("loop_var", None) Datatype.bool (Datatype.func2 - Stmt.ty + Stmt.ty Kernel_function.ty Db.Slicing.Select.dyn_t_set))) higher_select_stmt_annots @@ -653,7 +654,7 @@ ~label3:("rd", None) Datatype.String.Set.ty ~label4:("wr", None) Datatype.String.Set.ty (Datatype.func3 - ~label1:("scope", None) Stmt.ty + ~label1:("scope", None) Stmt.ty ~label2:("eval", None) Stmt.ty Kernel_function.ty Db.Slicing.Select.dyn_t_set)) @@ -713,7 +714,7 @@ ~label3:("spare", None) Datatype.bool ~label4:("ai", None) Datatype.bool (Datatype.func4 - ~label1:("user_assert", None) Datatype.bool + ~label1:("user_assert", None) Datatype.bool ~label2:("slicing_pragma", None) Datatype.bool ~label3:("loop_inv", None) Datatype.bool ~label4:("loop_var", None) Datatype.bool @@ -812,7 +813,7 @@ ~label3:("sliceUndef", None) Datatype.bool ~label4:("keepAnnotation", None) Datatype.bool (Datatype.func2 - ~label1:("print", None) Datatype.bool + ~label1:("print", None) Datatype.bool Datatype.unit Datatype.unit)) set_modes @@ -830,7 +831,7 @@ Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.Static.add_codependencies - ~onto:P.self + ~onto:P.self [ !Db.Pdg.self; !Db.Inputs.self_external; !Db.Outputs.self_external ]) (** {3 Register external functions into Db.Slicing} ) @@ -846,7 +847,7 @@ Db.register (Db.Journalize ("Slicing.Project.mk_project", - Datatype.func Datatype.string Db.Slicing.Project.dyn_t)) + Datatype.func Datatype.string Db.Slicing.Project.dyn_t)) Db.Slicing.Project.mk_project mk_project; Db.register @@ -859,10 +860,10 @@ (Db.Journalize ("Slicing.Project.change_slicing_level", Datatype.func3 - Db.Slicing.Project.dyn_t - Kernel_function.ty + Db.Slicing.Project.dyn_t + Kernel_function.ty Datatype.int - Datatype.unit)) + Datatype.unit)) Db.Slicing.Project.change_slicing_level M.change_slicing_level ; @@ -960,7 +961,7 @@ (Db.Journalize ("Slicing.Select.select_func_lval", Datatype.func4 - Db.Slicing.Select.dyn_t_set + Db.Slicing.Select.dyn_t_set Db.Slicing.Mark.dyn_t Datatype.String.Set.ty Kernel_function.ty @@ -991,9 +992,9 @@ Db.register (Db.Journalize ("Slicing.Slice.create", Datatype.func2 - Db.Slicing.Project.dyn_t + Db.Slicing.Project.dyn_t Kernel_function.ty - Db.Slicing.Slice.dyn_t)) + Db.Slicing.Slice.dyn_t)) Db.Slicing.Slice.create create_slice ; Db.register @@ -1061,14 +1062,14 @@ (Db.Journalize ("Slicing.Request.add_selection", Datatype.func2 - Db.Slicing.Project.dyn_t Db.Slicing.Select.dyn_t_set Datatype.unit)) + Db.Slicing.Project.dyn_t Db.Slicing.Select.dyn_t_set Datatype.unit)) Db.Slicing.Request.add_selection C.add_selection ; Db.register (Db.Journalize ("Slicing.Request.add_persistent_selection", Datatype.func2 - Db.Slicing.Project.dyn_t Db.Slicing.Select.dyn_t_set Datatype.unit)) + Db.Slicing.Project.dyn_t Db.Slicing.Select.dyn_t_set Datatype.unit)) Db.Slicing.Request.add_persistent_selection C.add_persistent_selection ; Db.register @@ -1085,16 +1086,16 @@ (Db.Journalize ("Slicing.Request.copy_slice", Datatype.func2 - Db.Slicing.Project.dyn_t - Db.Slicing.Slice.dyn_t - Db.Slicing.Slice.dyn_t)) + Db.Slicing.Project.dyn_t + Db.Slicing.Slice.dyn_t + Db.Slicing.Slice.dyn_t)) Db.Slicing.Request.copy_slice copy_slice ; Db.register (Db.Journalize ("Slicing.Request.split_slice", Datatype.func2 - Db.Slicing.Project.dyn_t + Db.Slicing.Project.dyn_t Db.Slicing.Slice.dyn_t (Datatype.list Db.Slicing.Slice.dyn_t))) Db.Slicing.Request.split_slice @@ -1151,7 +1152,7 @@ because some functions use its results, * and the value analysis is not launched automatically. *) !Db.Value.compute (); - + let project_name = SlicingParameters.ProjectName.get () in let project = !Db.Slicing.Project.mk_project project_name in !Db.Slicing.Project.set_project (Some project); @@ -1161,24 +1162,24 @@ if SlicingParameters.Mode.Callers.get () then !Db.Slicing.Slice.remove_uncalled project; - let sliced_project_name = + let sliced_project_name = let postfix = SlicingParameters.ExportedProjectPostfix.get () in if postfix = "" then project_name else (project_name ^ " " ^ postfix) in + SlicingParameters.set_off (); let sliced_project = !Db.Slicing.Project.extract sliced_project_name project in + Project.on sliced_project SlicingParameters.clear (); if SlicingParameters.Print.get () then begin FC_file.pretty_ast ~prj:sliced_project (); SlicingParameters.result ~level:2 "Results :@. %a@." - !Db.Slicing.Project.pretty project + !Db.Slicing.Project.pretty project end; SlicingParameters.feedback ~level:2 "done (slicing requests in progress)."; - SlicingParameters.set_off () end (** Register the function [main] as a main entry point. ) let () = Db.Main.extend main - diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/register.mli frama-c-20111001+nitrogen+dfsg/src/slicing/register.mli --- frama-c-20110201+carbon+dfsg/src/slicing/register.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/register.mli 2011-10-10 08:38:22.000000000 +0000 @@ -22,7 +22,7 @@ ( *) (**********************************************************************) -( +( * This file should be empty because every API functions of the slicing module * should be registered in {!Db.Slicing}. @@ -31,6 +31,5 @@ ) -val print_fct_stmts : - Format.formatter -> (SlicingTypes.sl_project Db_types.kernel_function) -> unit - +val print_fct_stmts : + Format.formatter -> (SlicingTypes.sl_project * Cil_types.kernel_function) -> unit diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingActions.ml frama-c-20111001+nitrogen+dfsg/src/slicing/slicingActions.ml --- frama-c-20110201+carbon+dfsg/src/slicing/slicingActions.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingActions.ml 2011-10-10 08:38:22.000000000 +0000 @@ -22,7 +22,7 @@ (* *) (**********************************************************************) -( This module deals with the action management. +( This module deals with the action management. * It consiste of the definitions of the different kind of actions, * and the management of the action list. *) @@ -52,51 +52,51 @@ (** {3 How the elements will be selected} *) (** Build a description to tell that the associated nodes have to be marked -* with the given mark, and than the same one will be propagated through +* with the given mark, and than the same one will be propagated through * their dependencies. (see also {!build_node_and_dpds_selection}) *) -let build_simple_node_selection ?(nd_marks=[]) mark = +let build_simple_node_selection ?(nd_marks=[]) mark = (T.CwNode, mark)::nd_marks (** Only the control dependencies of the nodes will be marked *) -let build_addr_dpds_selection ?(nd_marks=[]) mark = +let build_addr_dpds_selection ?(nd_marks=[]) mark = (T.CwAddrDpds, mark)::nd_marks (** Only the control dependencies of the nodes will be marked *) -let build_data_dpds_selection ?(nd_marks=[]) mark = +let build_data_dpds_selection ?(nd_marks=[]) mark = (T.CwDataDpds, mark)::nd_marks (** Only the control dependencies of the nodes will be marked *) -let build_ctrl_dpds_selection ?(nd_marks=[]) mark = +let build_ctrl_dpds_selection ?(nd_marks=[]) mark = (T.CwCtrlDpds, mark)::nd_marks (** Build a description to tell how the selected PDG nodes and their -* dependencies will have to be marked -* (see {!type:SlicingTypes.Internals.t_node_or_dpds}). +* dependencies will have to be marked +* (see {!type:SlicingTypes.Internals.t_node_or_dpds}). * This description depend on the mark that has been asked for. * First of all, whatever the mark is, the node is selected as [spare], -* so that it will be visible, and so will its dependencies. Then, +* so that it will be visible, and so will its dependencies. Then, * if [is_ctrl mark] propagate a m1 control mark through the control dependencies * and do a similar thing for [addr] and [data] *) let build_node_and_dpds_selection ?(nd_marks=[]) mark = let m_spare = Marks.mk_user_spare in let nd_marks = build_simple_node_selection ~nd_marks:nd_marks m_spare in - let nd_marks = + let nd_marks = if Marks.is_ctrl_mark mark - then + then let m_ctrl = Marks.mk_user_mark ~ctrl:true ~data:false ~addr:false in build_ctrl_dpds_selection ~nd_marks:nd_marks m_ctrl else nd_marks in - let nd_marks = + let nd_marks = if Marks.is_addr_mark mark - then + then let m_addr = Marks.mk_user_mark ~ctrl:false ~data:false ~addr:true in build_addr_dpds_selection ~nd_marks:nd_marks m_addr else nd_marks in - let nd_marks = + let nd_marks = if Marks.is_data_mark mark - then + then let m_data = Marks.mk_user_mark ~ctrl:false ~data:true ~addr:false in build_data_dpds_selection ~nd_marks:nd_marks m_data else nd_marks @@ -108,9 +108,9 @@ let translate_crit_to_select pdg ?(to_select=[]) list_crit = let translate acc (nodes, nd_mark) = let add_pdg_mark acc (nd, mark) = - let add_nodes m acc nodes = - let add m acc nodepart = - PdgMarks.add_node_to_select acc nodepart m + let add_nodes m acc nodes = + let add m acc nodepart = + PdgMarks.add_node_to_select acc nodepart m in List.fold_left (add m) acc nodes in @@ -136,7 +136,7 @@ (** build an action to apply the criteria to the persistent selection of the * function. It means that it will be applied to all slices. *) -let mk_fct_crit fi crit = +let mk_fct_crit fi crit = T.CrFct { T.cf_fct = T.FctSrc fi ; T.cf_info = crit } let mk_fct_user_crit fi crit = mk_fct_crit fi (T.CcUserMark crit) @@ -144,11 +144,11 @@ let mk_crit_fct_top fi m = mk_fct_user_crit fi (T.CuTop m) let mk_crit_fct_user_select fi select = mk_fct_user_crit fi (T.CuSelect select) -let mk_crit_prop_persit_marks fi node_marks = +let mk_crit_prop_persit_marks fi node_marks = mk_fct_crit fi (T.CcPropagate node_marks) (** build an action to apply the criteria to the given slice. ) -let mk_ff_crit ff crit = +let mk_ff_crit ff crit = T.CrFct { T.cf_fct = T.FctSliced ff ; T.cf_info = crit } let mk_ff_user_select ff crit = mk_ff_crit ff (T.CcUserMark (T.CuSelect crit)) @@ -172,23 +172,23 @@ let caller = M.get_fi_kf fi_caller in let pdg_caller = !Db.Pdg.get caller in let call_stmts = !Db.Pdg.find_call_stmts ~caller to_call in - let stmt_mark stmt = + let stmt_mark stmt = let stmt_ctrl_node = !Db.Pdg.find_call_ctrl_node pdg_caller stmt in (PdgMarks.mk_select_node stmt_ctrl_node, mark) in let select = List.map stmt_mark call_stmts in T.CuSelect select with PdgTypes.Pdg.Top -> T.CuTop mark - in + in mk_fct_user_crit fi_caller select let mk_crit_add_output_marks ff select = ( let pdg = M.get_ff_pdg ff in - let add acc (out, m) = + let add acc (out, m) = let nd_m = build_simple_node_selection m in let node = out in - mk_mark_nodes pdg ~marks:acc [node] nd_m + mk_mark_nodes pdg ~marks:acc [node] nd_m in let select = List.fold_left add [] output_marks in ) mk_ff_user_select ff select @@ -216,49 +216,49 @@ let rec print_nd_and_mark_list fmt ndm_list = match ndm_list with | [] -> () - | x :: ndm_list -> + | x :: ndm_list -> print_nd_and_mark fmt x; print_nd_and_mark_list fmt ndm_list let print_nodes fmt nodes = - let print n = Format.fprintf fmt "n%a " (!Db.Pdg.pretty_node true) n in + let print n = Format.fprintf fmt "%a " (!Db.Pdg.pretty_node true) n in List.iter print nodes let print_node_mark fmt n z m = - Format.fprintf fmt "(%a ,%a)" + Format.fprintf fmt "(%a ,%a)" (PdgTypes.Node.pretty_with_part) (n, z) Marks.pretty_mark m let print_sel_marks_list fmt to_select = - let print_sel (s, m) = match s with + let print_sel (s, m) = match s with | PdgMarks.SelNode (n, z) -> print_node_mark fmt n z m - | PdgMarks.SelIn l -> - Format.fprintf fmt "(UndefIn %a:%a)" + | PdgMarks.SelIn l -> + Format.fprintf fmt "(UndefIn %a:%a)" Locations.Zone.pretty l Marks.pretty_mark m in match to_select with [] -> Format.fprintf fmt "<empty>" | _ -> List.iter print_sel to_select let print_ndm fmt (nodes, ndm_list) = - Format.fprintf fmt "(%a,%a)" print_nodes nodes + Format.fprintf fmt "(%a,%a)" print_nodes nodes print_nd_and_mark_list ndm_list let print_f_crit fmt f_crit = - match f_crit with + match f_crit with | T.CuTop m -> Format.fprintf fmt "top(%a)" Marks.pretty_mark m | T.CuSelect to_select -> print_sel_marks_list fmt to_select let print_crit fmt crit = - match crit with - | T.CrFct fct_crit -> + match crit with + | T.CrFct fct_crit -> let fct = fct_crit.T.cf_fct in let name = SlicingMacros.f_name fct in Format.fprintf fmt "[%s = " name; let _ = match fct_crit.T.cf_info with - | T.CcUserMark info -> print_f_crit fmt info + | T.CcUserMark info -> print_f_crit fmt info | T.CcMissingInputs (call, _input_marks, more_inputs) - -> Format.fprintf fmt "missing_inputs for call %d (%s)" - call.Cil_types.sid + -> Format.fprintf fmt "missing_inputs for call %d (%s)" + call.Cil_types.sid (if more_inputs then "more_inputs" else "marks only") | T.CcMissingOutputs (call, _output_marks, more_outputs) - -> Format.fprintf fmt "missing_outputs for call %d (%s)" + -> Format.fprintf fmt "missing_outputs for call %d (%s)" call.Cil_types.sid (if more_outputs then "more_outputs" else "marks only") | T.CcChooseCall call @@ -268,14 +268,14 @@ | T.CallSlice ff -> SlicingMacros.ff_name ff | T.CallSrc (Some fi) -> ("(src:"^( SlicingMacros.fi_name fi)^")") | T.CallSrc None -> "(src)" - in Format.fprintf fmt "change_call for call %d -> %s" + in Format.fprintf fmt "change_call for call %d -> %s" call.Cil_types.sid fname - | T.CcPropagate nl -> - Format.fprintf fmt "propagate %a" + | T.CcPropagate nl -> + Format.fprintf fmt "propagate %a" print_sel_marks_list nl | T.CcExamineCalls _ -> Format.fprintf fmt "examine_calls" in Format.fprintf fmt "]" - | T.CrAppli (T.CaCall fi) -> + | T.CrAppli (T.CaCall fi) -> let name = SlicingMacros.fi_name fi in Format.fprintf fmt "[Appli : calls to %s]" name | _ -> diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingActions.mli frama-c-20111001+nitrogen+dfsg/src/slicing/slicingActions.mli --- frama-c-20110201+carbon+dfsg/src/slicing/slicingActions.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingActions.mli 2011-10-10 08:38:22.000000000 +0000 @@ -26,7 +26,7 @@ type t_select = t_mark PdgMarks.t_select ( ~~~~~~~~~~~~~~~) -( selection mode (ie which mark to associate to the node +( selection mode (ie which mark to associate to the node and how to propagate in the different kinds of dependencies) ) type t_n_or_d_marks @@ -42,7 +42,7 @@ ?nd_marks:t_n_or_d_marks -> t_mark -> t_n_or_d_marks ( ~) val translate_crit_to_select : - Db.Pdg.t -> ?to_select:t_select -> + Db.Pdg.t -> ?to_select:t_select -> ((Db.Pdg.t_node Locations.Zone.t option) list * t_n_or_d_marks) list -> t_select (* ~) @@ -68,7 +68,7 @@ t_fct_slice -> t_mark PdgMarks.t_info_called_outputs -> t_criterion val mk_appli_select_calls : t_fct_info -> t_criterion val mk_crit_mark_calls : - t_fct_info -> Db_types.kernel_function -> t_mark -> t_criterion + t_fct_info -> Cil_types.kernel_function -> t_mark -> t_criterion val mk_crit_add_output_marks : t_fct_slice -> t_select -> t_criterion ( ~~~~~~~~~~~~~~~*) diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingCmds.ml frama-c-20111001+nitrogen+dfsg/src/slicing/slicingCmds.ml --- frama-c-20110201+carbon+dfsg/src/slicing/slicingCmds.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingCmds.ml 2011-10-10 08:38:22.000000000 +0000 @@ -32,7 +32,6 @@ open Cilutil open Cil_types open Db -open Db_types (** Utilities for [kinstr]. *) module Kinstr: sig @@ -100,7 +99,7 @@ match ki.skind with | Instr (Call (_,expr_f,_,_)) -> Kernel_function.Hptset.elements - (snd (!Value.expr_to_kernel_function + (snd (!Value.expr_to_kernel_function (Kstmt ki) ~with_alarms:CilE.warn_none_mode ~deps:None @@ -114,9 +113,9 @@ (** Get directly read/writen [Zone.t] by the statement. * i.e. directly means when [ki] is a call, it doesn't don't look at the assigns clause of the called function. ) - let get_rw_zone ki = ( returns [Zone.t read],[Zone.t writen] ) + let get_rw_zone stmt = ( returns [Zone.t read],[Zone.t writen] ) assert (Db.Value.is_computed ()); - let lval_process read_zone kstmt lv = + let lval_process read_zone stmt lv = ( returns [read_zone] joined to [Zone.t read] by [lv], [Zone.t writen] by [lv] ) let deps, looking_for = ( The modified locationss are [looking_for], those address are @@ -124,30 +123,28 @@ !Db.Value.lval_to_loc_with_deps ~with_alarms:CilE.warn_none_mode ~deps:read_zone - kstmt + (Kstmt stmt) lv - in deps, Locations.valid_enumerate_bits looking_for - in match ki.skind with + in deps, Locations.valid_enumerate_bits ~for_writing:true looking_for + in match stmt.skind with | Switch (exp,_,_,_) | If (exp,_,_,_) -> (* returns [Zone.t read] by condition [exp], [Zone.bottom] ) - !Db.From.find_deps_no_transitivity (Kstmt ki) exp, Locations.Zone.bottom + !Db.From.find_deps_no_transitivity stmt exp, Locations.Zone.bottom | Instr (Set (lv,exp,_)) -> ( returns [Zone.t read] by [exp, lv], [Zone.t writen] by [lv] ) - let kstmt = Kstmt ki in - let read_zone = !Db.From.find_deps_no_transitivity kstmt exp in - lval_process read_zone kstmt lv + let read_zone = !Db.From.find_deps_no_transitivity stmt exp in + lval_process read_zone stmt lv | Instr (Call (lvaloption,funcexp,argl,_)) -> ( returns [Zone.t read] by [lvaloption, funcexp, argl], [Zone.t writen] by [lvaloption] ) - let kstmt = Kstmt ki in - let read_zone = !Db.From.find_deps_no_transitivity kstmt funcexp in + let read_zone = !Db.From.find_deps_no_transitivity stmt funcexp in let add_args arg inputs = - Locations.Zone.join inputs (!Db.From.find_deps_no_transitivity kstmt arg) in + Locations.Zone.join inputs (!Db.From.find_deps_no_transitivity stmt arg) in let read_zone = List.fold_right add_args argl read_zone in let read_zone,write_zone = match lvaloption with | None ->read_zone , Locations.Zone.bottom - | Some lv -> lval_process read_zone kstmt lv + | Some lv -> lval_process read_zone stmt lv in read_zone,write_zone | _ -> Locations.Zone.bottom, Locations.Zone.bottom @@ -155,8 +152,8 @@ directly read/writen [Zone.t] by the statement. i.e. directly means when [ki] is a call, it doesn't don't look at the assigns clause of the called function. *) - let is_rw_zone (rd_zone_opt, wr_zone_opt) ki = - let rd_zone, wr_zone = get_rw_zone ki in + let is_rw_zone (rd_zone_opt, wr_zone_opt) stmt = + let rd_zone, wr_zone = get_rw_zone stmt in let inter_zone zone_opt zone = match zone_opt with | None -> zone_opt @@ -206,7 +203,7 @@ (fun kf -> SlicingParameters.debug ~level:3 "doing topologic propagation for function: %a" - Kernel_function.pretty_name kf; + Kernel_function.pretty kf; !Slicing.Request.apply_all_internal project) let add_to_selection set selection = @@ -220,10 +217,10 @@ (** Registered as a slicing selection function: Add a selection of the statement. ) -let select_stmt set ~spare ki kf = +let select_stmt set ~spare stmt kf = let stmt_mark = !Db.Slicing.Mark.make ~data:(not spare) ~addr:(not spare) ~ctrl:(not spare) in - let selection = !Db.Slicing.Select.select_stmt_internal kf ki stmt_mark + let selection = !Db.Slicing.Select.select_stmt_internal kf stmt stmt_mark in add_to_selection set selection ( Add a selection to the entrance of the function [kf] @@ -233,7 +230,7 @@ let select_entry_point_and_some_inputs_outputs set ~mark kf ~return ~outputs ~inputs = SlicingParameters.debug ~level:3 "select_entry_point_and_some_inputs_outputs %a" - Kernel_function.pretty_name kf ; + Kernel_function.pretty kf ; let set = let selection = !Db.Slicing.Select.select_entry_point_internal kf mark in add_to_selection set selection in @@ -320,13 +317,18 @@ try let ki = Kernel_function.find_return kf in select_stmt set ~spare ki kf - with Kernel_function.No_Definition -> - let mark = !Db.Slicing.Mark.make - ~data:(not spare) ~addr:(not spare) ~ctrl:(not spare) + with Kernel_function.No_Statement -> + let mark = + !Db.Slicing.Mark.make + ~data:(not spare) ~addr:(not spare) ~ctrl:(not spare) in - select_entry_point_and_some_inputs_outputs set ~mark kf - ~return:true ~outputs:Locations.Zone.bottom - ~inputs:Locations.Zone.bottom + select_entry_point_and_some_inputs_outputs + set + ~mark + kf + ~return:true + ~outputs:Locations.Zone.bottom + ~inputs:Locations.Zone.bottom ( Registered as a slicing selection function: Add a selection of the statement reachability. @@ -365,18 +367,18 @@ (fun lval_str acc -> let lval_term = !Db.Properties.Interp.lval kf scope lval_str in let lval = - !Db.Properties.Interp.term_lval_to_lval ~result:None lval_term - in + !Db.Properties.Interp.term_lval_to_lval ~result:None lval_term + in let loc = - !Db.Value.lval_to_loc - ~with_alarms:CilE.warn_none_mode - (Kstmt eval) - lval - in - let zone = Locations.valid_enumerate_bits loc in - Locations.Zone.join zone acc) + !Db.Value.lval_to_loc + ~with_alarms:CilE.warn_none_mode + (Kstmt eval) + lval + in + let zone = Locations.valid_enumerate_bits ~for_writing:false loc in + Locations.Zone.join zone acc) lval_str - Locations.Zone.bottom + Locations.Zone.bottom in select_stmt_zone set mark zone ~before ki kf @@ -393,7 +395,7 @@ of a call. ) let select_lval_rw set mark ~rd ~wr ~scope ~eval kf ki_opt= assert (Db.Value.is_computed ()); - let zone_option lval_str = + let zone_option ~for_writing lval_str = if Datatype.String.Set.is_empty lval_str then None else @@ -403,18 +405,18 @@ let lval_term = !Db.Properties.Interp.lval kf scope lval_str in let lval = !Db.Properties.Interp.term_lval_to_lval ~result:None lval_term in let loc = !Db.Value.lval_to_loc ~with_alarms:CilE.warn_none_mode (Kstmt eval) lval in - let zone = Locations.valid_enumerate_bits loc + let zone = Locations.valid_enumerate_bits ~for_writing loc in Locations.Zone.join zone acc) lval_str Locations.Zone.bottom in SlicingParameters.debug ~level:3 "select_lval_rw %a zone=%a" - Kernel_function.pretty_name kf + Kernel_function.pretty kf Locations.Zone.pretty zone; Some zone in - let zone_rd_opt = zone_option rd in - let zone_wr_opt = zone_option wr - in match zone_rd_opt, zone_wr_opt with + let zone_rd_opt = zone_option ~for_writing:false rd in + let zone_wr_opt = zone_option ~for_writing:true wr in + match zone_rd_opt, zone_wr_opt with | None, None -> set | (_, _) as zone_option_rw -> let ac = ref set in @@ -434,12 +436,12 @@ in (match ki_opt with | Some ki -> select_rw_from_stmt kf ki | None -> - Globals.Functions.iter - (fun kf -> + Globals.Functions.iter + (fun kf -> if !Db.Value.is_called kf then - if Kernel_function.is_definition kf - then (* Called function with source code: just looks at its stmt ) - Kinstr.iter_from_func (select_rw_from_stmt kf) kf + if not (!Db.Value.use_spec_instead_of_definition kf) + then ( Called function with source code: just looks at its stmt ) + Kinstr.iter_from_func (select_rw_from_stmt kf) kf else begin ( Called function without source code: looks at its effect ) let select_inter_zone fsel zone_opt zone = match zone_opt with @@ -510,10 +512,10 @@ (fun z acc -> ( selection related to the parsing/compilation of the annotation *) select_stmt_zone acc mark - z.Properties.Interp.To_zone.zone + z.Properties.Interp.To_zone.zone ~before:z.Properties.Interp.To_zone.before - z.Properties.Interp.To_zone.ki - kf) + z.Properties.Interp.To_zone.ki + kf) zones set let get_or_raise (info_data_opt, info_decl) = match info_data_opt with @@ -526,25 +528,25 @@ (** Registered as a slicing selection function: Add selection of the annotations related to a statement. Note: add also a transparent selection on the whole statement. *) -let select_stmt_pred set mark pred ~before ki kf = +let select_stmt_pred set mark pred ki kf = let zones_decl_vars = !Properties.Interp.To_zone.from_pred pred - (!Properties.Interp.To_zone.mk_ctx_stmt_annot kf ki ~before) + (!Properties.Interp.To_zone.mk_ctx_stmt_annot kf ki) in select_ZoneAnnot_zones_decl_vars set mark (get_or_raise zones_decl_vars) kf (** Registered as a slicing selection function: Add selection of the annotations related to a statement. Note: add also a transparent selection on the whole statement. *) -let select_stmt_term set mark term ~before ki kf = - let zones_decl_vars = !Properties.Interp.To_zone.from_term term (!Properties.Interp.To_zone.mk_ctx_stmt_annot kf ki ~before) +let select_stmt_term set mark term ki kf = + let zones_decl_vars = !Properties.Interp.To_zone.from_term term (!Properties.Interp.To_zone.mk_ctx_stmt_annot kf ki) in select_ZoneAnnot_zones_decl_vars set mark (get_or_raise zones_decl_vars) kf (** Registered as a slicing selection function: Add selection of the annotations related to a statement. Note: add also a transparent selection on the whole statement. ) -let select_stmt_annot set mark ~spare annot ~before ki kf = +let select_stmt_annot set mark ~spare annot ki kf = let zones_decl_vars,pragmas = - !Properties.Interp.To_zone.from_stmt_annot annot ~before (ki, kf) + !Properties.Interp.To_zone.from_stmt_annot annot (ki, kf) in let set = select_ZoneAnnot_pragmas set ~spare pragmas kf in select_ZoneAnnot_zones_decl_vars set mark (get_or_raise zones_decl_vars) kf @@ -661,49 +663,49 @@ Globals.Functions.iter (fun kf -> let add_selection opt select = - if Datatype.String.Set.mem (Kernel_function.get_name kf) (opt ()) - then selection := select !selection ~spare:false kf + if Datatype.String.Set.mem (Kernel_function.get_name kf) (opt ()) + then selection := select !selection ~spare:false kf in add_selection - SlicingParameters.Select.Return.get + SlicingParameters.Select.Return.get !Db.Slicing.Select.select_func_return; add_selection - SlicingParameters.Select.Calls.get - !Db.Slicing.Select.select_func_calls_to; + SlicingParameters.Select.Calls.get + !Db.Slicing.Select.select_func_calls_to; add_selection - SlicingParameters.Select.Pragma.get - (fun s -> !Db.Slicing.Select.select_func_annots s top_mark - ~ai:false ~user_assert:false ~slicing_pragma:true - ~loop_inv:false ~loop_var:false); + SlicingParameters.Select.Pragma.get + (fun s -> !Db.Slicing.Select.select_func_annots s top_mark + ~ai:false ~user_assert:false ~slicing_pragma:true + ~loop_inv:false ~loop_var:false); add_selection - SlicingParameters.Select.Threat.get + SlicingParameters.Select.Threat.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark - ~ai:true ~user_assert:false ~slicing_pragma:false - ~loop_inv:false ~loop_var:false); + ~ai:true ~user_assert:false ~slicing_pragma:false + ~loop_inv:false ~loop_var:false); add_selection - SlicingParameters.Select.Assert.get + SlicingParameters.Select.Assert.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark - ~ai:false ~user_assert:true ~slicing_pragma:false - ~loop_inv:false ~loop_var:false); + ~ai:false ~user_assert:true ~slicing_pragma:false + ~loop_inv:false ~loop_var:false); add_selection - SlicingParameters.Select.LoopInv.get + SlicingParameters.Select.LoopInv.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark - ~ai:false ~user_assert:false ~slicing_pragma:false - ~loop_inv:true ~loop_var:false); + ~ai:false ~user_assert:false ~slicing_pragma:false + ~loop_inv:true ~loop_var:false); add_selection - SlicingParameters.Select.LoopVar.get + SlicingParameters.Select.LoopVar.get (fun s -> !Db.Slicing.Select.select_func_annots s top_mark - ~ai:false ~user_assert:false ~slicing_pragma:false - ~loop_inv:false ~loop_var:true); + ~ai:false ~user_assert:false ~slicing_pragma:false + ~loop_inv:false ~loop_var:true); ); if not (Datatype.String.Set.is_empty - (SlicingParameters.Select.Value.get ())) + (SlicingParameters.Select.Value.get ())) || not (Datatype.String.Set.is_empty - (SlicingParameters.Select.RdAccess.get ())) + (SlicingParameters.Select.RdAccess.get ())) || not (Datatype.String.Set.is_empty - (SlicingParameters.Select.WrAccess.get ())) + (SlicingParameters.Select.WrAccess.get ())) then begin ( fprintf fmt "@\n[-slice-value] Select %s at end of the entry point %a@." lval_str Db.pretty_name kf; ) diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingMacros.ml frama-c-20111001+nitrogen+dfsg/src/slicing/slicingMacros.ml --- frama-c-20110201+carbon+dfsg/src/slicing/slicingMacros.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingMacros.ml 2011-10-10 08:38:22.000000000 +0000 @@ -86,8 +86,11 @@ try Cil_datatype.Varinfo.Hashtbl.find proj.T.functions fct_var with Not_found -> let fi_def, is_def = - try let def = Kernel_function.get_definition kf in Some def, true - with Kernel_function.No_Definition -> None, false + match kf.fundec with + | Declaration _ -> None, false + | Definition _ when !Db.Value.use_spec_instead_of_definition kf -> + None, false + | Definition (def, _) -> Some def, true in let new_fi = { T.fi_kf = kf; @@ -178,7 +181,7 @@ let equal_fi fi1 fi2 = let v1 = fi_svar fi1 in let v2 = fi_svar fi2 in - v1.vid = v2.vid + Cil_datatype.Varinfo.equal v1 v2 let equal_ff ff1 ff2 = (equal_fi ff1.T.ff_fct ff2.T.ff_fct) && ((get_ff_id ff1) = (get_ff_id ff2)) @@ -205,9 +208,9 @@ let _funcexp_dpds, called_functions = !Db.Value.expr_to_kernel_function ~with_alarms:CilE.warn_none_mode - ~deps:(Some Locations.Zone.bottom) + ~deps:(Some Locations.Zone.bottom) (Kstmt call_stmt) - funcexp + funcexp in (match Kernel_function.Hptset.contains_single_elt called_functions with | Some kf -> kf diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingMarks.ml frama-c-20111001+nitrogen+dfsg/src/slicing/slicingMarks.ml --- frama-c-20110201+carbon+dfsg/src/slicing/slicingMarks.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingMarks.ml 2011-10-10 08:38:22.000000000 +0000 @@ -49,11 +49,11 @@ val is_top : t -> bool val is_included : t -> t -> bool - ( Total order over the marks. Used only for sorting... + ( Total order over the marks. Used only for sorting... Use rather [is_included] to make a clever comparison. ) val compare : t -> t -> int - ( this operation has to be commutative. + ( this operation has to be commutative. It is used to merge two slices into one. ) val merge : t -> t -> t @@ -61,13 +61,13 @@ val inter : t -> t -> t (** this operation add a new information to the old value. - * @return (new_mark, is_new) + * @return (new_mark, is_new) where is_new=true if the new_mark is not included in the old one. ) val combine : old:t -> t -> bool t (** [minus m1 m2] provides the mark [m] that you have to merge with [m2] to - * get at least [m1]. So : [m1 <= m U m2] + * get at least [m1]. So : [m1 <= m U m2] * If [m1 <= m2] then [m = bot]. * ) val minus : t -> t -> t @@ -79,21 +79,21 @@ type t = T.t_mark - + let spare = T.Spare ( Internal constructor ) let create_adc a d c = T.Cav (D.make ~a ~d ~c ()) - + let bottom = T.Cav D.bottom let top = T.Cav D.top - - let addr = create_adc true false false + + let addr = create_adc true false false let data = create_adc false true false let ctrl = create_adc false false true - - let m_ad = create_adc true true false - let m_ac = create_adc true false true + + let m_ad = create_adc true true false + let m_ac = create_adc true false true let m_dc = create_adc false true true let create adc = @@ -106,11 +106,11 @@ | true, false, true -> m_ac | false, true, true -> m_dc | true, true, true -> top - + ( External constructor sharing same values *) let mk_adc a d c = create (a, d, c) let mk_mark dpd = create (D.adc_value dpd) - + let is_bottom m = (m = bottom) let is_top m = (m = top) @@ -124,7 +124,7 @@ | T.Cav _, T.Spare -> if is_bottom m1 then true else false | T.Cav d1, T.Cav d2 -> D.is_included d1 d2 - let merge m1 m2 = + let merge m1 m2 = match m1,m2 with | T.Spare, T.Spare -> m1 | T.Spare, T.Cav _ -> if is_bottom m2 then m1 else m2 @@ -138,19 +138,19 @@ match m1,m2 with | T.Spare, _ -> m1 | _, T.Spare -> m2 - | T.Cav d1, T.Cav d2 -> + | T.Cav d1, T.Cav d2 -> let m = mk_mark (D.inter d1 d2) in if is_bottom m then spare else m - let combine ~old m = + let combine ~old m = match old, m with | T.Spare, T.Spare -> (false, old) - | T.Cav old_d, T.Spare -> + | T.Cav old_d, T.Spare -> if D.is_bottom old_d then (true, m) else (false, old) - | T.Spare, T.Cav new_d -> + | T.Spare, T.Cav new_d -> if D.is_bottom new_d then (false, old) else (true, m) | T.Cav old_d, T.Cav new_d -> - let new_d = D.combine old_d new_d in + let new_d = D.combine old_d new_d in if old_d = new_d then (false, old) else (true, mk_mark new_d) let minus m1 m2 = @@ -161,16 +161,16 @@ | T.Cav d1, T.Cav d2 -> mk_mark (D.minus d1 d2) let pretty fmt m = - match m with + match m with | T.Cav d -> D.pretty fmt d | T.Spare -> Format.fprintf fmt "[ S ]" let to_string m = Pretty_utils.sfprintf "%a" pretty m end - -(** a [MarkPair] is associated with each element of the PDG in a slice. - * The first component gives the mark propagated from a user request, while + +(** a [MarkPair] is associated with each element of the PDG in a slice. + * The first component gives the mark propagated from a user request, while * the second one is used to propagate informations to the called functions. ) module MarkPair = struct @@ -178,7 +178,7 @@ ( To do hash-consing *) let create = SlicingInternals.create_sl_mark - + let mk_m1 m1 = create ~m1 ~m2:Mark.bottom let mk_m2 m2 = create ~m1:Mark.bottom ~m2 let mk_m m1 m2 = create ~m1 ~m2 @@ -202,12 +202,12 @@ let is_addr m = (Mark.is_included Mark.addr (user_mark m)) let is_data m = (Mark.is_included Mark.data (user_mark m)) - let is_spare m = + let is_spare m = not (is_bottom m) && not (is_ctrl m || is_addr m || is_data m) let compare = T.compare_pdg_mark - let is_included ma mb = + let is_included ma mb = (Mark.is_included ma.T.m1 mb.T.m1) && (Mark.is_included ma.T.m2 mb.T.m2) let pretty fmt m = @@ -215,19 +215,19 @@ in Format.fprintf fmt "<%a,%a>" pm m.T.m1 pm m.T.m2 let to_string m = - Pretty_utils.sfprintf "%a" pretty m + Pretty_utils.sfprintf "%a" pretty m - let minus ma mb = + let minus ma mb = mk_m (Mark.minus ma.T.m1 mb.T.m1) (Mark.minus ma.T.m2 mb.T.m2) (** see {! Mark.merge} *) - let merge ma mb = + let merge ma mb = let m1 = Mark.merge ma.T.m1 mb.T.m1 in let m2 = Mark.merge ma.T.m2 mb.T.m2 in mk_m m1 m2 (** merge only ma_1 et mb_1, m_2 is always bottom ) - let merge_user_marks ma mb = + let merge_user_marks ma mb = let m1 = Mark.merge ma.T.m1 mb.T.m1 in mk_m m1 Mark.bottom @@ -237,7 +237,7 @@ | m :: [] -> m ( to avoid merging with bottom every time ! *) | m :: tl -> merge m (merge_all tl) - let inter ma mb = + let inter ma mb = let m1 = Mark.inter ma.T.m1 mb.T.m1 in let m2 = Mark.inter ma.T.m2 mb.T.m2 in mk_m m1 m2 @@ -251,7 +251,7 @@ (** [combine ma mb] is used to add the [mb] to the [ma]. * @return two marks : the first one is the new mark (= merge), * and the second is the one to propagate. - * Notice that if the mark to propagate is bottom, + * Notice that if the mark to propagate is bottom, * it means that [mb] was included in [ma]. *) let combine ma mb = @@ -264,12 +264,12 @@ let new_m2, prop2 = combine_m ma.T.m2 mb.T.m2 in (mk_m new_m1 new_m2), (mk_m prop1 prop2) - (** we want to know if the called function [g] with output marks - * [m_out_called] compute enough things to be used in [f] call + (** we want to know if the called function [g] with output marks + * [m_out_called] compute enough things to be used in [f] call * with output marks [m_out_call]. * Remember the [mf1] marks propagates as [mg2] and the marks to add * can only be [m2] marks. - * TODO : write this down in the specification + * TODO : write this down in the specification * and check with Patrick if it is ok. * ) let missing_output ~call:m_out_call ~called:m_out_called = @@ -284,13 +284,13 @@ Mark.merge mf1 mf2 in let min_mg2 = ( let remove from needed_mg2 what we have in mg1 ) Mark.minus needed_mg2 mg1 in - if Mark.is_included min_mg2 mg2 then None + if Mark.is_included min_mg2 mg2 then None else let m2 = mk_m2 min_mg2 in - if debug then + if debug then Format.printf "check_out missing output -> %a\n" pretty m2; (Some m2) - ( tells if the caller ([f]) computes enough inputs for the callee ([g]). + ( tells if the caller ([f]) computes enough inputs for the callee ([g]). Remember that [mg1] has to be propagated as [mf1], * but [mg2] has to be propagated as [mf2=spare] *) let missing_input ~call:m_in_call ~called:m_in_called = @@ -299,7 +299,7 @@ let mg1 = m_in_called.T.m1 in let mg2 = m_in_called.T.m2 in let new_mf1 = if Mark.is_included mg1 mf1 then Mark.bottom else mg1 in - let new_mf2 = + let new_mf2 = if (not (Mark.is_bottom mg2)) && (Mark.is_bottom mf2) then Mark.spare else Mark.bottom @@ -353,8 +353,8 @@ Signature.fold_all_inputs (fun acc (k, m) -> (k, m)::acc) [] sgn exception Visible - let raise_if_visible () (_, m) = - if M.is_bottom m then () else raise Visible + let raise_if_visible () (_, m) = + if M.is_bottom m then () else raise Visible let some_visible_out cm = try Signature.fold_all_outputs raise_if_visible () cm ; false @@ -362,24 +362,24 @@ let is_topin_visible cm = try - let m = get_in_top_mark cm in + let m = get_in_top_mark cm in if M.is_bottom m then false else true - with PdgIndex.NotFound -> false + with Not_found -> false let ctrl_visible cm = try - let ctrl_m = get_in_ctrl_mark cm in + let ctrl_m = get_in_ctrl_mark cm in if M.is_bottom ctrl_m then false else true - with PdgIndex.NotFound -> false + with Not_found -> false let some_visible_in cm = try Signature.fold_num_inputs raise_if_visible () cm ; ctrl_visible cm with Visible -> true let merge_inputs_m1_mark cm = - Signature.fold_all_inputs (fun acc (_, m) -> M.merge_user_marks acc m) + Signature.fold_all_inputs (fun acc (_, m) -> M.merge_user_marks acc m) M.bottom cm - + (** @return an under-approxamation of the mark for the given location. * If the location is not included in the union of the implicit inputs, * it returns bottom. @@ -392,19 +392,19 @@ assert (not (Locations.Zone.equal Locations.Zone.bottom loc)); let do_in (marked_inputs, marks) (in_loc, m) = if M.is_bottom m then (marked_inputs, []) - else if Locations.Zone.intersects in_loc loc - then + else if Locations.Zone.intersects in_loc loc + then let marked_inputs = Locations.Zone.link marked_inputs in_loc in let marks = m::marks in (marked_inputs, marks) else (marked_inputs, marks) - in + in let marked_inputs = Locations.Zone.bottom in - let marked_inputs, marks = + let marked_inputs, marks = Signature.fold_impl_inputs do_in (marked_inputs, []) cm in - let m = - if Locations.Zone.is_included loc marked_inputs + let m = + if Locations.Zone.is_included loc marked_inputs then M.inter_all marks else M.bottom in @@ -413,7 +413,7 @@ M.pretty m; m - let something_visible cm = + let something_visible cm = some_visible_out cm || some_visible_in cm || ctrl_visible cm (** @return the mark that has to be associated to the call statement. @@ -421,7 +421,7 @@ ) let rec combined_marks cm = let add_m m (_, m2) = M.merge m m2 in - Signature.fold add_m M.bottom cm + Signature.fold add_m M.bottom cm let add_spare out_marks max_out = let rec add_out lst n = @@ -434,21 +434,21 @@ ( let same_output_visibility sig1 sig2 = let check sig_b () (num_out, m_a) = - let m_b = + let m_b = try Signature.find_output sig_b num_out - with Not_found -> M.bottom + with Not_found -> M.bottom in if (M.is_bottom m_a) <> (M.is_bottom m_b) then raise SlicingMacros.Break in let same = try - Signature.fold_outputs (check sig2) () sig1; + Signature.fold_outputs (check sig2) () sig1; Signature.fold_outputs (check sig1) () sig2; true with SlicingMacros.Break -> false in same *) - + (** check if the output marks in [called_marks] are enough for the * [call_marks]. * @return a list of (output number, mark) that are missing, @@ -456,15 +456,15 @@ * would make more visible outputs. * ) ( - let check_output called_marks (new_marks, more_outputs) (num_out, m_call) = - let m_called = - try Signature.find_output called_marks num_out + let check_output called_marks (new_marks, more_outputs) (num_out, m_call) = + let m_called = + try Signature.find_output called_marks num_out with Not_found -> M.bottom in let missing_m = M.missing_output ~call:m_call ~called:m_called in - let new_marks, more_outputs = match missing_m with + let new_marks, more_outputs = match missing_m with | None -> new_marks, more_outputs - | Some missing_m -> + | Some missing_m -> let new_output = M.is_bottom m_called in (num_out, missing_m) :: new_marks, more_outputs || new_output in new_marks, more_outputs @@ -474,8 +474,8 @@ let called_marks = match called_marks_opt with | Some called_marks -> called_marks | None -> empty - in - if debug then + in + if debug then Format.printf "with called = %a\n" pretty called_marks; called_marks @@ -485,42 +485,42 @@ List.fold_left (check_output called_marks) ([], false) new_call_marks let check_called_output_marks call_marks called_marks_opt = - if debug then - Format.printf "check_called_output_marks : call = %a\n" + if debug then + Format.printf "check_called_output_marks : call = %a\n" pretty call_marks; let called_marks = get_called_marks called_marks_opt in Signature.fold_outputs (check_output called_marks) ([], false) call_marks *) - let check_input sgn result (in_key, mark) = + let check_input sgn result (in_key, mark) = let add_if_needed m_sgn (in_key, m_input) (marks, more) = if debug then Format.printf "check_input : sgn=%a ; needed=%a\n" M.pretty m_sgn M.pretty m_input; let missing_m = M.missing_input ~call:m_sgn ~called:m_input in - match missing_m with + match missing_m with | None -> marks, more - | Some missing_m -> + | Some missing_m -> let new_input = M.is_bottom m_sgn in (in_key, missing_m) :: marks, more || new_input in - let m_sgn = + let m_sgn = try Signature.find_in_info sgn in_key - with PdgIndex.NotFound -> M.bottom + with Not_found -> M.bottom in add_if_needed m_sgn (in_key, mark) result let check_input_marks sgn input_marks = List.fold_left (check_input sgn) ([], false) input_marks (** check if the input marks in [call_marks] are enough to call a slice with - * [called_marks]. + * [called_marks]. * @return a list of (input number, mark) that are missing, - * and a boolean that says if the propagation in the call + * and a boolean that says if the propagation in the call * would make more visible inputs in the call signature. * ) let check_called_input_marks call_marks called_marks_opt = match called_marks_opt with - | Some called_marks -> + | Some called_marks -> let result = Signature.fold_all_inputs (check_input call_marks) ([], false) called_marks in result (missing_marks, more_inputs) @@ -538,7 +538,7 @@ end -( The mark associated with a call stmt is composed of +( The mark associated with a call stmt is composed of marks for the call inputs (numbered form 1 to [max_in]) * and marks for the call outputs (numbered from 0 to [max_out] *) module SigMarks = F_SigMarks (MarkPair) @@ -551,8 +551,8 @@ let bottom_mark = MarkPair.bottom let mk_gen_spare = MarkPair.mk_gen_spare let mk_user_spare = MarkPair.mk_m1_spare -let mk_user_mark ~data ~addr ~ctrl = - if addr || data || ctrl then +let mk_user_mark ~data ~addr ~ctrl = + if addr || data || ctrl then MarkPair.mk_m1 (Mark.mk_adc addr data ctrl) else mk_user_spare @@ -596,5 +596,3 @@ let check_called_input_marks = SigMarks.check_called_input_marks let get_marked_out_zone = SigMarks.get_marked_out_zone let pretty_sig = SigMarks.pretty - - diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingMarks.mli frama-c-20111001+nitrogen+dfsg/src/slicing/slicingMarks.mli --- frama-c-20110201+carbon+dfsg/src/slicing/slicingMarks.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingMarks.mli 2011-10-10 08:38:22.000000000 +0000 @@ -42,7 +42,7 @@ val inter_marks : t_mark list -> t_mark (** [combine_marks] add a new information to the old value. -* @return (new_mark, is_new) +* @return (new_mark, is_new) where [is_new=true] if the new mark is not included in the old one. ) val combine_marks : t_mark -> t_mark -> (t_mark t_mark) @@ -59,7 +59,7 @@ val empty_sig : t_sig_marks val get_input_mark : t_sig_marks -> int -> t_mark -val get_all_input_marks : t_sig_marks -> +val get_all_input_marks : t_sig_marks -> (PdgIndex.Signature.t_in_key * t_mark) list val merge_inputs_m1_mark : t_sig_marks -> t_mark val get_input_loc_under_mark : t_sig_marks -> Locations.Zone.t -> t_mark @@ -69,16 +69,15 @@ val some_visible_out : t_sig_marks -> bool val is_topin_visible : t_sig_marks -> bool (* -val check_output_marks : (int * t_mark) list -> t_sig_marks option -> +val check_output_marks : (int * t_mark) list -> t_sig_marks option -> (int * t_mark) list * bool val check_called_output_marks : t_sig_marks -> t_sig_marks option -> (int * t_mark) list * bool -val check_input_marks : t_sig_marks -> - (PdgIndex.Signature.t_in_key * t_mark) list -> +val check_input_marks : t_sig_marks -> + (PdgIndex.Signature.t_in_key * t_mark) list -> (PdgIndex.Signature.t_in_key * t_mark) list * bool -val check_called_input_marks : t_sig_marks -> t_sig_marks option -> +val check_called_input_marks : t_sig_marks -> t_sig_marks option -> (PdgIndex.Signature.t_in_key * t_mark) list * bool ) val get_marked_out_zone : t_sig_marks -> bool Locations.Zone.t val pretty_sig : Format.formatter -> t_sig_marks -> unit - diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingParameters.ml frama-c-20111001+nitrogen+dfsg/src/slicing/slicingParameters.ml --- frama-c-20110201+carbon+dfsg/src/slicing/slicingParameters.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingParameters.ml 2011-10-10 08:38:22.000000000 +0000 @@ -38,184 +38,201 @@ module Calls = StringSet (struct - let option_name = "-slice-calls" - let arg_name = "f1, ..., fn" - let help = - "select every calls to functions f1,...,fn, and all their effect" + let option_name = "-slice-calls" + let arg_name = "f1, ..., fn" + let help = + "select every calls to functions f1,...,fn, and all their effect" let kind = `Correctness end) module Return = StringSet (struct - let option_name = "-slice-return" - let arg_name = "f1, ..., fn" - let help = - "select the result (returned value) of functions f1,...,fn" + let option_name = "-slice-return" + let arg_name = "f1, ..., fn" + let help = + "select the result (returned value) of functions f1,...,fn" let kind = `Correctness end) module Threat = StringSet (struct - let option_name = "-slice-threat" - let arg_name = "f1, ..., fn" - let help = "select the threats of functions f1,...,fn" + let option_name = "-slice-threat" + let arg_name = "f1, ..., fn" + let help = "select the threats of functions f1,...,fn" let kind = `Correctness end) module Assert = StringSet (struct - let option_name = "-slice-assert" - let arg_name = "f1, ..., fn" - let help = "select the assertions of functions f1,...,fn" + let option_name = "-slice-assert" + let arg_name = "f1, ..., fn" + let help = "select the assertions of functions f1,...,fn" let kind = `Correctness end) module LoopInv = StringSet (struct - let option_name = "-slice-loop-inv" - let arg_name = "f1, ..., fn" - let help = "select the loop invariants of functions f1,...,fn" + let option_name = "-slice-loop-inv" + let arg_name = "f1, ..., fn" + let help = "select the loop invariants of functions f1,...,fn" let kind = `Correctness end) module LoopVar = StringSet (struct - let option_name = "-slice-loop-var" - let arg_name = "f1, ..., fn" - let help = "select the loop variants of functions f1,...,fn" + let option_name = "-slice-loop-var" + let arg_name = "f1, ..., fn" + let help = "select the loop variants of functions f1,...,fn" let kind = `Correctness end) module Pragma = StringSet (struct - let option_name = "-slice-pragma" - let arg_name = "f1, ..., fn" + let option_name = "-slice-pragma" + let arg_name = "f1, ..., fn" let kind = `Correctness - let help = - "use the slicing pragmas in the code of functions f1,...,fn as \ + let help = + "use the slicing pragmas in the code of functions f1,...,fn as \ slicing criteria" - let () = Plugin.set_optional_help + let () = Plugin.set_optional_help "@;<0 0>@[<hov>@[<hov 4>//@@slice pragma ctrl; @ to@ reach@ this@ \ control-flow@ point@]@\n\ @[<hov 4>//@@slice pragma expr <expr_desc;> @ to@ preserve@ the@ value@ of@ \ an@ expression@ at@ this@ control-flow@ point@]@\n\ @[<hov 4>//@@slice pragma stmt; @ to@ preserve@ the@ effect@ of@ the@ next@ \ statement@]@]" - end) + end) module RdAccess = StringSet - (struct + (struct let kind = `Correctness - let module_name = "Slicing.Select.RdAccess" - let option_name = "-slice-rd" - let arg_name = "v1, ..., vn" - let help = - "select the read accesses to left-values v1,...,vn \ - (addresses are evaluated at the beginning of the function given as \ + let module_name = "Slicing.Select.RdAccess" + let option_name = "-slice-rd" + let arg_name = "v1, ..., vn" + let help = + "select the read accesses to left-values v1,...,vn \ + (addresses are evaluated at the beginning of the function given as \ entry point)" - end) + end) module WrAccess = StringSet - (struct + (struct let kind = `Correctness - let module_name = "Slicing.Select.WrAccess" - let option_name = "-slice-wr" - let arg_name = "v1, ..., vn" - let help = - "select the write accesses to left-values v1,...,vn \ - (addresses are evaluated at the beginning of the function given as\ + let module_name = "Slicing.Select.WrAccess" + let option_name = "-slice-wr" + let arg_name = "v1, ..., vn" + let help = + "select the write accesses to left-values v1,...,vn \ + (addresses are evaluated at the beginning of the function given as\ entry point)" - end) + end) module Value = StringSet - (struct + (struct let kind = `Correctness - let module_name = "Slicing.Select.Value" - let option_name = "-slice-value" - let arg_name = "v1, ..., vn" - let help = - "select the result of left-values v1,...,vn at the end of the \ + let module_name = "Slicing.Select.Value" + let option_name = "-slice-value" + let arg_name = "v1, ..., vn" + let help = + "select the result of left-values v1,...,vn at the end of the \ function given as entry point (addresses are evaluated at the beginning of \ the function given as entry point)" - end) + end) end module Mode = struct module Callers = True(struct - let option_name = "-slice-callers" - let help = "propagate the slicing to the function callers" + let option_name = "-slice-callers" + let help = "propagate the slicing to the function callers" let kind = `Tuning - end) + end) module Calls = Int (struct - let option_name = "-slicing-level" - let default = 2 - let arg_name = "" - let help = "set the default level of slicing used to propagate to \ + let option_name = "-slicing-level" + let default = 2 + let arg_name = "" + let help = "set the default level of slicing used to propagate to \ the calls\n\ - 0 : don't slice the called functions\n\ - 1 : don't slice the called functions but propagate the marks anyway\n\ - 2 : try to use existing slices, create at most one\n\ - 3 : most precise slices\n\ + 0 : don't slice the called functions\n\ + 1 : don't slice the called functions but propagate the marks anyway\n\ + 2 : try to use existing slices, create at most one\n\ + 3 : most precise slices\n\ note: this value (defaults to 2) is not used for calls to undefined \ functions\n\ - except when '-slice-undef-functions' option is set" + except when '-slice-undef-functions' option is set" let kind = `Tuning - end) + end) let () = Calls.set_range ~min:0 ~max:3 module SliceUndef = False(struct - let option_name = "-slice-undef-functions" - let help = "allow the use of the -slicing-level option for calls \ + let option_name = "-slice-undef-functions" + let help = "allow the use of the -slicing-level option for calls \ to undefined functions" let kind = `Tuning - end) + end) module KeepAnnotations = False(struct - let option_name = "-slicing-keep-annotations" - let help = "keep annotations as long as the used variables are \ + let option_name = "-slicing-keep-annotations" + let help = "keep annotations as long as the used variables are \ declared and the accessibility of the program point is preserved (even if the \ value of the data is not preserved)" let kind = `Correctness - end) + end) end module ProjectName = String(struct - let option_name = "-slicing-project-name" - let arg_name = "" - let help = "name of the slicing project (defaults to \"Slicing\")" - let default = "Slicing" + let option_name = "-slicing-project-name" + let arg_name = "" + let help = "name of the slicing project (defaults to \"Slicing\")" + let default = "Slicing" let kind = `Tuning - end) + end) module ExportedProjectPostfix = String(struct - let option_name = "-slicing-exported-project-postfix" - let arg_name = "" - let help = "postfix added to the slicing project name for building the name of the exported project (defaults to \"export\")" - let default = "export" + let option_name = "-slicing-exported-project-postfix" + let arg_name = "" + let help = "postfix added to the slicing project name for building \ +the name of the exported project (defaults to \"export\")" + let default = "export" let kind = `Tuning - end) - -module Print = - False(struct - let option_name = "-slice-print" - let help = "pretty print the sliced code" - let kind = `Tuning - end) + end) + +module Print = struct + let new_command = "<normal slicing command> -then-on 'Slicing export' -print" + include False(struct + let option_name = "-slice-print" + let help = "deprecated. Use instead " ^ new_command + let kind = `Tuning + end) + (* Just a small hack to inform the end-user that he is using a deprecated + option without changing the old behavior (incompatible with -ocode for + instance). ) + let get () = + let b = get () in + if b then deprecated "-slice-print" ~now:new_command (fun () -> ()) (); + b +end + +module Force = + True(struct + let option_name = "-slice-force" + let help = "force slicing" + let kind = `Tuning + end) module OptionModified = State_builder.Ref @@ -227,13 +244,6 @@ let default () = true end) -module Force = - True(struct - let option_name = "-slice-force" - let help = "don't slice" - let kind = `Tuning - end) - let () = State_dependency_graph.Static.add_codependencies ~onto:OptionModified.self @@ -270,12 +280,25 @@ let set_off () = Force.off () ; - OptionModified.set false ; + OptionModified.set false +let clear () = + Force.clear () ; + Select.Calls.clear () ; + Select.Return.clear () ; + Select.Threat.clear () ; + Select.Assert.clear () ; + Select.LoopInv.clear () ; + Select.LoopVar.clear () ; + Select.Pragma.clear () ; + Select.RdAccess.clear () ; + Select.WrAccess.clear () ; + Select.Value.clear () ; + OptionModified.clear () ( Local Variables: -compile-command: "LC_ALL=C make -C ../.." +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingParameters.mli frama-c-20111001+nitrogen+dfsg/src/slicing/slicingParameters.mli --- frama-c-20110201+carbon+dfsg/src/slicing/slicingParameters.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingParameters.mli 2011-10-10 08:38:22.000000000 +0000 @@ -28,32 +28,33 @@ ( modules related to the command line options *) module Select : sig - module Calls: Plugin.STRING_SET - module Return: Plugin.STRING_SET - module Threat: Plugin.STRING_SET - module Assert: Plugin.STRING_SET - module Pragma: Plugin.STRING_SET - module LoopInv: Plugin.STRING_SET - module LoopVar: Plugin.STRING_SET - module RdAccess: Plugin.STRING_SET - module WrAccess: Plugin.STRING_SET - module Value: Plugin.STRING_SET + module Calls: Plugin.String_set + module Return: Plugin.String_set + module Threat: Plugin.String_set + module Assert: Plugin.String_set + module Pragma: Plugin.String_set + module LoopInv: Plugin.String_set + module LoopVar: Plugin.String_set + module RdAccess: Plugin.String_set + module WrAccess: Plugin.String_set + module Value: Plugin.String_set end - + module Mode : sig - module Callers: Plugin.BOOL - module Calls: Plugin.INT - module SliceUndef: Plugin.BOOL - module KeepAnnotations: Plugin.BOOL + module Callers: Plugin.Bool + module Calls: Plugin.Int + module SliceUndef: Plugin.Bool + module KeepAnnotations: Plugin.Bool end -(** @since Carbon-20101202+dev *) -module ProjectName: Plugin.STRING - -(** @since Carbon-20101202+dev *) -module ExportedProjectPostfix: Plugin.STRING +(** @since Carbon-20110201 *) +module ProjectName: Plugin.String + +(** @since Carbon-20110201 *) +module ExportedProjectPostfix: Plugin.String + +module Print: Plugin.Bool -module Print: Plugin.BOOL - val is_on: unit -> bool val set_off: unit -> unit +val clear: unit -> unit diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingProject.ml frama-c-20111001+nitrogen+dfsg/src/slicing/slicingProject.ml --- frama-c-20110201+carbon+dfsg/src/slicing/slicingProject.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingProject.ml 2011-10-10 08:38:22.000000000 +0000 @@ -358,8 +358,8 @@ add_persistante_marks proj fi node_marks false propagate [] | T.CcExamineCalls _ | _ -> - Extlib.not_yet_implemented - "This slicing criterion on source function" + Extlib.not_yet_implemented + "This slicing criterion on source function" (** apply [filter] and return a list of generated filters ) let apply_action proj filter = @@ -403,17 +403,24 @@ apply new_filters; apply actions in - SlicingParameters.feedback ~level:1 "applying %d actions..." nb_actions; - let rec apply_user n = - try let a = get_next_filter proj in - SlicingParameters.feedback ~level:1 "applying actions: %d/%d..." n nb_actions; - let new_filters = apply_action proj a in - apply new_filters; - apply_user (n+1) - with Not_found -> - if nb_actions > 0 then - SlicingParameters.feedback ~level:2 "done (applying %d actions." nb_actions - in - apply_user 1 - + SlicingParameters.feedback ~level:1 "applying %d actions..." nb_actions; + let rec apply_user n = + try + let a = get_next_filter proj in + SlicingParameters.feedback ~level:1 "applying actions: %d/%d..." + n nb_actions; + let new_filters = apply_action proj a in + apply new_filters; + apply_user (n+1) + with Not_found -> + if nb_actions > 0 then + SlicingParameters.feedback + ~level:2 "done (applying %d actions." nb_actions + in + apply_user 1 +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingTransform.ml frama-c-20111001+nitrogen+dfsg/src/slicing/slicingTransform.ml --- frama-c-20110201+carbon+dfsg/src/slicing/slicingTransform.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingTransform.ml 2011-10-10 08:38:22.000000000 +0000 @@ -50,8 +50,8 @@ else begin table := Cil_datatype.Varinfo.Set.add vf !table ; List.exists - (fun (kf,_) -> exists_fun_callers kf) - (!Db.Value.callers kf) + (fun (kf,_) -> exists_fun_callers kf) + (!Db.Value.callers kf) end in exists_fun_callers kf @@ -67,7 +67,7 @@ in exists_fun_callers fpred kf module Visibility (SliceName : sig - val get : Db_types.kernel_function -> bool -> int -> string + val get : kernel_function -> bool -> int -> string end) = struct exception EraseAssigns @@ -85,7 +85,7 @@ let slices = M.fi_slices fi in let src_visible = is_src_fun_visible project kf in SlicingParameters.debug ~level:1 "[SlicingTransform.Visibility.fct_info] processing %a (%d slices/src %svisible)" - Kernel_function.pretty_name kf (List.length slices) + Kernel_function.pretty kf (List.length slices) (if src_visible then "" else "not "); let need_addr = (Kernel_function.get_vi kf).vaddrof in let src_name_used = src_visible || need_addr in @@ -128,7 +128,11 @@ | Iproto -> false | Iff (ff,_) -> let m = !Db.Slicing.Slice.get_mark_from_label ff inst label in - visible_mark m + let v = visible_mark m in + SlicingParameters.debug ~level:2 + "[SlicingTransform.Visibility.label_visible] label %a is %svisible" + !Ast_printer.d_label label (if v then "" else "in"); + v let data_in_visible ff data_in = match data_in with | None -> true @@ -137,14 +141,11 @@ compute [data_in] or not, but let's see if, by chance, * some data have been selected manually... ) let m = Fct_slice.get_input_loc_under_mark ff data_in in - if !Db.Slicing.Mark.is_bottom m then - begin - SlicingParameters.debug ~level:2 - "[SlicingTransform.Visibility.data_in_visible] data %a invisible" - Locations.Zone.pretty data_in; - false - end - else true + let v = visible_mark m in + SlicingParameters.debug ~level:2 + "[SlicingTransform.Visibility.data_in_visible] data %a is %svisible" + Locations.Zone.pretty data_in (if v then "" else "in"); + v let all_nodes_visible ff nodes = let is_visible visi n = @@ -201,7 +202,7 @@ in case we end up with NotImplemented somewhere, we keep the annotation iff all C variables occuring in there are visible. ) - let all_logic_var_visible, all_logic_var_visible_term, + let all_logic_var_visible, all_logic_var_visible_term, all_logic_var_visible_assigns, all_logic_var_visible_deps = let module Exn = struct exception Invisible end in let vis ff = object @@ -242,7 +243,7 @@ ignore (Visitor.visitFramacTerm (vis ff) d.it_content); true with Exn.Invisible -> false) - let annotation_visible ff_opt stmt ~before annot = + let annotation_visible ff_opt stmt annot = SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.annotation_visible] ?"; match ff_opt with @@ -253,7 +254,7 @@ let pdg = !Db.Pdg.get kf in try let ctrl_nodes, decl_nodes, data_info = - !Db.Pdg.find_code_annot_nodes pdg before stmt annot + !Db.Pdg.find_code_annot_nodes pdg stmt annot in let data_visible = data_nodes_visible ff (decl_nodes, data_info) in let visible = ((all_nodes_visible ff ctrl_nodes) && data_visible) in @@ -327,7 +328,7 @@ let fun_assign_visible ff_opt v = let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in - SlicingParameters.debug ~level:2 + SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_assign_visible \ (with keep_annots = %B)] ?" keep_annots; @@ -343,7 +344,7 @@ let fun_deps_visible ff_opt v = let keep_annots = SlicingParameters.Mode.KeepAnnotations.get () in - SlicingParameters.debug ~level:2 + SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_deps_visible \ (with keep_annots = %B)] ?" keep_annots; @@ -352,8 +353,8 @@ | Isrc -> true | Iproto -> true | Iff (ff,_) -> all_logic_var_visible_deps ff v - in - SlicingParameters.debug ~level:2 + in + SlicingParameters.debug ~level:2 "[SlicingTransform.Visibility.fun_deps_visible] -> %s" (if visible then "yes" else "no"); visible @@ -374,7 +375,7 @@ try let m = PdgIndex.FctIndex.find_info ff_marks key in visible_mark m - with PdgIndex.NotFound -> false + with Not_found -> false let result_visible _kf ff = match ff with | Isrc | Iproto -> true @@ -384,7 +385,7 @@ try let m = PdgIndex.FctIndex.find_info ff_marks key in visible_mark m - with PdgIndex.NotFound -> false + with Not_found -> false let called_info (project, ff) call_stmt = let info = match ff with @@ -404,7 +405,7 @@ let kf_ff = M.get_ff_kf ff in let src_visible = is_src_fun_visible project kf_ff in (Some (kf_ff, Iff (ff, src_visible))) - with PdgIndex.NotFound -> + with Not_found -> (* the functor should call [called_info] only for visible calls *) assert false in @@ -426,10 +427,14 @@ let module S = struct let get = f_slice_names end in let module Visi = Visibility (S) in let module Transform = Filter.F (Visi) in - let tmp_prj = Transform.build_cil_file (new_proj_name ^ " tmp") slicing_project in - let new_prj = !Db.Sparecode.rm_unused_globals ~new_proj_name:new_proj_name ~project:tmp_prj () in + let tmp_prj = + Transform.build_cil_file (new_proj_name ^ " tmp") slicing_project + in + let new_prj = + !Db.Sparecode.rm_unused_globals ~new_proj_name ~project:tmp_prj () + in Project.remove ~project:tmp_prj (); - let ctx = Parameters.get_selection_context () in + let ctx = Plugin.get_selection_context () in Project.copy ~selection:ctx new_prj; SlicingParameters.feedback ~level:2 "done (exporting project to '%s')." new_proj_name; diff -Nru frama-c-20110201+carbon+dfsg/src/slicing/slicingTransform.mli frama-c-20111001+nitrogen+dfsg/src/slicing/slicingTransform.mli --- frama-c-20110201+carbon+dfsg/src/slicing/slicingTransform.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing/slicingTransform.mli 2011-10-10 08:38:22.000000000 +0000 @@ -24,23 +24,23 @@ (** Export a CIL application from a slicing project *) -val default_slice_names:(Db_types.kernel_function -> bool -> int -> string) - -(** Apply the actions still waiting in the project -* and transform the program (CIL AST) using slicing results +val default_slice_names:(Cil_types.kernel_function -> bool -> int -> string) + +(** Apply the actions still waiting in the project +* and transform the program (CIL AST) using slicing results * Can optionally specify how to name the sliced functions using [f_slice_names]. * (see db.mli) ) val extract : - f_slice_names:(Db_types.kernel_function -> bool -> int -> string) + f_slice_names:(Cil_types.kernel_function -> bool -> int -> string) -> string -> Db.Slicing.Project.t -> Project.t - -( Return [true] if the source function is called + +( Return [true] if the source function is called (even indirectly via transitivity) from a [Slice.t]. ) -val is_src_fun_called : - Db.Slicing.Project.t -> Db_types.kernel_function -> bool - -( Return [true] if the source function is visible +val is_src_fun_called : + Db.Slicing.Project.t -> Cil_types.kernel_function -> bool + +( Return [true] if the source function is visible (even indirectly via transitivity) from a [Slice.t]. *) -val is_src_fun_visible : - Db.Slicing.Project.t -> Db_types.kernel_function -> bool +val is_src_fun_visible : + Db.Slicing.Project.t -> Cil_types.kernel_function -> bool diff -Nru frama-c-20110201+carbon+dfsg/src/slicing_types/slicingInternals.ml frama-c-20111001+nitrogen+dfsg/src/slicing_types/slicingInternals.ml --- frama-c-20110201+carbon+dfsg/src/slicing_types/slicingInternals.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing_types/slicingInternals.ml 2011-10-10 08:38:30.000000000 +0000 @@ -73,6 +73,9 @@ (** Each PDG element has 2 marks to deal with interprocedural propagation ) type t_pdg_mark = {m1 : t_mark ; m2 : t_mark } +let t_pdg_mark_packed_descr = Structural_descr.p_abstract + ( Ok: Dpd.t is in fact int *) + let compare_pdg_mark p1 p2 = if p1 == p2 then 0 else @@ -85,7 +88,7 @@ (** Type for all the informations related to any function, * even if we don't have its definition. *) and t_fct_info = { - fi_kf : Db_types.kernel_function; + fi_kf : Cil_types.kernel_function; fi_def : Cil_types.fundec option; fi_project : t_project; mutable fi_top : t_pdg_mark option; diff -Nru frama-c-20110201+carbon+dfsg/src/slicing_types/slicingTypes.ml frama-c-20111001+nitrogen+dfsg/src/slicing_types/slicingTypes.ml --- frama-c-20110201+carbon+dfsg/src/slicing_types/slicingTypes.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/slicing_types/slicingTypes.ml 2011-10-10 08:38:30.000000000 +0000 @@ -67,11 +67,9 @@ let reprs = [ SlicingInternals.dummy_t_fct_user_crit ] let name = "SlicingTypes.Fct_user_crit" let mem_project = Datatype.never_any_project + let varname _ = "user_criteria" end) -(** A set of selections, grouped by function *) -module Sl_selects = Cil_datatype.Varinfo.Map - (** Function slice ) type sl_fct_slice = SlicingInternals.t_fct_slice @@ -105,10 +103,11 @@ include Datatype.Undefined ( TODO: unmarshal ) type t = sl_select let reprs = - List.map - (fun v -> v, SlicingInternals.dummy_t_fct_user_crit) - Cil_datatype.Varinfo.reprs + List.map + (fun v -> v, SlicingInternals.dummy_t_fct_user_crit) + Cil_datatype.Varinfo.reprs let name = "SlicingTypes.Sl_select" + let varname _s = "sl_select" let mem_project = Datatype.never_any_project end) @@ -144,27 +143,27 @@ | _, SlicingInternals.Spare -> None | SlicingInternals.Cav mark1, SlicingInternals.Cav mark2 -> if (PdgTypes.Dpd.is_bottom mark2) then - ( use [!Db.Slicing.Mark.make] contructor ) + ( use [!Db.Slicing.Mark.make] contructor ) Some (fun fmt -> Format.fprintf fmt "@[<hv 2>!Db.Slicing.Mark.make@;~addr:%b@;~data:%b@;~ctrl:%b@]" (PdgTypes.Dpd.is_addr mark1) - (PdgTypes.Dpd.is_data mark1) - (PdgTypes.Dpd.is_ctrl mark1)) + (PdgTypes.Dpd.is_data mark1) + (PdgTypes.Dpd.is_ctrl mark1)) else - None + None in let pp = match pp with | Some pp -> pp | None -> - let pp fmt sub_m = match sub_m with - ( use internals constructors ) + let pp fmt sub_m = match sub_m with + ( use internals constructors ) | SlicingInternals.Spare -> Format.fprintf fmt "SlicingInternals.Spare" | SlicingInternals.Cav pdg_m -> Format.fprintf fmt "@[<hv 2>(SlicingInternals.Cav@;@[<hv 2>(PdgTypes.Dpd.make@;~a:%b@;~d:%b@;~c:%b@;())@])@]" - (PdgTypes.Dpd.is_addr pdg_m) - (PdgTypes.Dpd.is_data pdg_m) - (PdgTypes.Dpd.is_ctrl pdg_m) - in + (PdgTypes.Dpd.is_addr pdg_m) + (PdgTypes.Dpd.is_data pdg_m) + (PdgTypes.Dpd.is_ctrl pdg_m) + in fun fmt -> Format.fprintf fmt "@[<hv 2>SlicingInternals.create_sl_mark@;~m1:%a@;~m2:%a@]" pp m.SlicingInternals.m1 pp m.SlicingInternals.m2 diff -Nru frama-c-20110201+carbon+dfsg/src/sparecode/globs.ml frama-c-20111001+nitrogen+dfsg/src/sparecode/globs.ml --- frama-c-20110201+carbon+dfsg/src/sparecode/globs.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/sparecode/globs.ml 2011-10-10 08:38:24.000000000 +0000 @@ -26,7 +26,10 @@ open Cilutil open Cil -let debug format = Sparecode_params.debug ~level:2 format +let dkey = "globs" + +let debug format = Sparecode_params.debug ~dkey ~level:2 format +let debug' format = Sparecode_params.debug ~dkey ~level:3 format let used_variables = Hashtbl.create 257 let var_init = Hashtbl.create 257 @@ -53,7 +56,7 @@ name... ) if Hashtbl.mem used_typeinfo ti.tname then SkipChildren else begin - debug "[sparecode:globs] add used typedef %s@." ti.tname; + debug "add used typedef %s@." ti.tname; Hashtbl.add used_typeinfo ti.tname (); ignore (visitCilType (self:>Cil.cilVisitor) ti.ttype); DoChildren @@ -61,13 +64,13 @@ | TEnum(ei,_) -> if Hashtbl.mem used_enuminfo ei.ename then SkipChildren else begin - debug "[sparecode:globs] add used enum %s@." ei.ename; + debug "add used enum %s@." ei.ename; Hashtbl.add used_enuminfo ei.ename (); DoChildren end | TComp(ci,_,_) -> if Hashtbl.mem used_compinfo ci.cname then SkipChildren else begin - debug "[sparecode:globs] add used comp %s@." ci.cname; + debug "add used comp %s@." ci.cname; Hashtbl.add used_compinfo ci.cname (); List.iter (fun f -> ignore (visitCilType (self:>Cil.cilVisitor) f.ftype)) @@ -78,7 +81,7 @@ method vvrbl v = if v.vglob && not (Hashtbl.mem used_variables v) then begin - debug "[sparecode:globs] add used var %s@." v.vname; + debug "add used var %s@." v.vname; Hashtbl.add used_variables v (); ignore (visitCilType (self:>Cil.cilVisitor) v.vtype); try @@ -90,14 +93,20 @@ method vglob_aux g = match g with | GFun (f, _) -> - debug "[sparecode:globs] add function %s@." f.svar.vname; + debug "add function %s@." f.svar.vname; Hashtbl.add used_variables f.svar (); Cil.DoChildren | GAnnot _ -> Cil.DoChildren | GVar (v, init, _) -> - (match init.init with None -> () - | Some i -> Hashtbl.add var_init v i); - Cil.SkipChildren + let _ = match init.init with | None -> () + | Some init -> + begin + Hashtbl.add var_init v init; + if Hashtbl.mem used_variables v then + ( already used before its initialization (see bug #758) ) + ignore (visitCilInit (self:>Cil.cilVisitor) v NoOffset init) + end + in Cil.SkipChildren | GVarDecl(_,v,_) when isFunctionType v.vtype -> DoChildren | _ -> Cil.SkipChildren @@ -115,27 +124,27 @@ | GVarDecl (_, v, _loc) -> ( variable/function declaration ) if Hashtbl.mem used_variables v then DoChildren else begin - debug "[sparecode:globs] remove var %s@." v.vname; + debug "remove var %s@." v.vname; ChangeTo [] end | GType (ti, _loc) ( typedef ) -> if Hashtbl.mem used_typeinfo ti.tname then DoChildren else begin - debug "[sparecode:globs] remove typedef %s@." ti.tname; + debug "remove typedef %s@." ti.tname; ChangeTo [] end | GCompTag (ci, _loc) ( struct/union definition ) | GCompTagDecl (ci, _loc) ( struct/union declaration ) -> if Hashtbl.mem used_compinfo ci.cname then DoChildren else begin - debug "[sparecode:globs] remove comp %s@." ci.cname; + debug "remove comp %s@." ci.cname; ChangeTo [] end | GEnumTag (ei, _loc) ( enum definition ) | GEnumTagDecl (ei, _loc) ( enum declaration ) -> if Hashtbl.mem used_enuminfo ei.ename then DoChildren else begin - debug "[sparecode:globs] remove enum %s@." ei.ename; + debug "remove enum %s@." ei.ename; DoChildren ( ChangeTo [] *) end | _ -> Cil.DoChildren @@ -156,7 +165,7 @@ Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.Static.add_codependencies - ~onto:Result.self + ~onto:Result.self [ !Db.Pdg.self; !Db.Outputs.self_external ]) let rm_unused_decl = @@ -165,12 +174,12 @@ clear_tables (); let visitor = new collect_visitor in ignore - (Visitor.visitFramacFile - (visitor:>Visitor.frama_c_visitor) (Ast.get ())); - debug "[sparecode:globs] filtering done@."; + (Visitor.visitFramacFile + (visitor:>Visitor.frama_c_visitor) (Ast.get ())); + debug "filtering done@."; let visitor = new filter_visitor in let new_prj = File.create_project_from_visitor new_proj_name visitor in - let ctx = Parameters.get_selection_context () in + let ctx = Plugin.get_selection_context () in Project.copy ~selection:ctx new_prj; new_prj) diff -Nru frama-c-20110201+carbon+dfsg/src/sparecode/marks.ml frama-c-20111001+nitrogen+dfsg/src/sparecode/marks.ml --- frama-c-20110201+carbon+dfsg/src/sparecode/marks.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/sparecode/marks.ml 2011-10-10 08:38:24.000000000 +0000 @@ -23,8 +23,13 @@ (**********************************************************************) let debug n format = Sparecode_params.debug ~level:n format +let fatal fmt = Sparecode_params.fatal fmt -let fatal text = Sparecode_params.fatal text +() +( The project is composed of [FctIndex] marked with [BoolMark] +* to be used by [Pdg.Register.F_Proj], and another table to store if a function +* is visible (usefull for Top PDG). ) +() module BoolMark = struct type prop_mode = Glob | Loc @@ -34,6 +39,8 @@ let bottom = false,Loc let top = true,Glob + let visible (b,_) = b + let mk glob = if glob then (true,Glob) else (true, Loc) let merge (b1,p1) (b2,p2) = @@ -58,6 +65,26 @@ (match p with Glob -> "Glob" | Loc -> "Loc") end +module KfTopVisi = struct + include Cil_datatype.Kf.Hashtbl + + let add proj kf b = add (snd proj) kf b + + let find proj kf = find (snd proj) kf + + ( as soon as a TOP function is called, all its callees are called. ) + let rec set proj kf = + try find proj kf + with Not_found -> + add proj kf (); + debug 1 "select '%a' as fully visible (top or called by top)" + Kernel_function.pretty kf; + let callees = !Db.Users.get kf in + Kernel_function.Hptset.iter (set proj) callees + + let get proj kf = try find proj kf; true with Not_found -> false +end + (** when we first compute marks to select outputs, * we don't immediately propagate input marks to the calls, * because some calls may be useless and we don't want to compute @@ -66,23 +93,30 @@ * lead to them : so, we propagate... * ) let call_in_to_check = ref [] +let called_top = ref [] module Config = struct - module M = struct - include BoolMark - end + module M = BoolMark let mark_to_prop_to_caller_input call_opt pdg_caller sel_elem m = match m with | true, M.Glob -> Some m | true, M.Loc -> - call_in_to_check := + call_in_to_check := (pdg_caller, call_opt, sel_elem, m) :: !call_in_to_check; None | _ -> fatal "cannot propagate invisible mark@." - let mark_to_prop_to_called_output _call _pdg _node m = - match m with + let mark_to_prop_to_called_output _call called_pdg = + if PdgTypes.Pdg.is_top called_pdg then + begin + let kf = PdgTypes.Pdg.get_kf called_pdg in + called_top := kf :: !called_top; + debug 1 "memo call to TOP '%a'" Kernel_function.pretty kf; + (fun _ _ -> None) + end + else + fun _n m -> match m with | true, M.Glob -> Some (true, M.Loc) | true, M.Loc -> Some m | _ -> fatal "cannot propagate invisible mark@." @@ -91,13 +125,28 @@ module ProjBoolMarks = Pdg.Register.F_Proj (Config) -type t_proj = ProjBoolMarks.t +type t_proj = ProjBoolMarks.t unit KfTopVisi.t type t_fct = ProjBoolMarks.t_fct -let get_marks proj kf = - ProjBoolMarks.find_marks proj (Kernel_function.get_vi kf) +let new_project () = (ProjBoolMarks.empty, KfTopVisi.create 10) -let mark_visible _fm (b,_) = b +() +( Get stored information ) +() + +let proj_marks proj = fst proj + +( @raise Not_found when the function is not marked. It might be the case + that it is nonetheless visible, but has no marks because of a Top PDG. *) +let get_marks proj kf = + try KfTopVisi.find proj kf ; None + with Not_found -> + ProjBoolMarks.find_marks (proj_marks proj) (Kernel_function.get_vi kf) + +(** Useful only if there has been some Pdg.Top *) +let kf_visible proj kf = + try KfTopVisi.find proj kf ; true + with Not_found -> get_marks proj kf <> None let rec key_visible fm key = try @@ -106,37 +155,75 @@ let call = PdgIndex.Key.call_from_id call_id in call_visible fm call | _ -> let m = PdgIndex.FctIndex.find_info fm key in - mark_visible fm m - with PdgIndex.NotFound -> false + BoolMark.visible m + with Not_found -> false and -(** the call is visible if its control node is visible ) - call_visible fm call = - let key = PdgIndex.Key.call_ctrl_key call in - key_visible fm key - ( - try - let _, call_sgn = PdgIndex.FctIndex.find_call fm call in - let test old_v (_, m) = old_v || (mark_visible fm m) in - let visible = - let visible = PdgIndex.Signature.fold_all_outputs test false call_sgn in - visible - with PdgIndex.NotFound -> false - *) - - -let rec all_keys_visible fm keys = match keys with - | [] -> true - | k :: keys -> (key_visible fm k) && (all_keys_visible fm keys) - -let select_pdg_elements proj pdg to_select = - ProjBoolMarks.mark_and_propagate proj pdg to_select + (** the call is visible if its control node is visible ) + call_visible fm call = + let key = PdgIndex.Key.call_ctrl_key call in + key_visible fm key + +() +( Build selections and propagate. ) +() +( Doesn't mark yet, but add what has to be marked in the selection, +* and keep things sorted. ) let rec add_pdg_selection to_select pdg sel_mark = match to_select with - | [] -> [(pdg, [sel_mark])] + | [] -> + let l = match sel_mark with None -> [] | Some m -> [m] in [(pdg, l)] | (p, ln) :: tl -> - if Db.Pdg.from_same_fun p pdg then (p, sel_mark::ln):: tl + if Db.Pdg.from_same_fun p pdg + then + let ln = match sel_mark with None -> ln + | Some sel_mark -> sel_mark::ln + in (p, ln)::tl else (p, ln)::(add_pdg_selection tl pdg sel_mark) +let add_node_to_select glob to_select z_opt node = + PdgMarks.add_node_to_select to_select (node, z_opt) (BoolMark.mk glob) + +let add_nodes_and_undef_to_select + glob (ctrl_nodes, decl_nodes, data_info) to_select = + match data_info with + | None -> to_select ( don't select anything (computation failed) *) + | Some (data_nodes, undef) -> + let to_select = + List.fold_left (fun s n -> add_node_to_select glob s None n) + to_select ctrl_nodes + in + let to_select = + List.fold_left (fun s n -> add_node_to_select glob s None n) + to_select decl_nodes + in + let to_select = + List.fold_left (fun s (n,z_opt) -> add_node_to_select glob s z_opt n) + to_select data_nodes + in + let m = (BoolMark.mk glob) in + let to_select = PdgMarks.add_undef_in_to_select to_select undef m in + to_select + +(** Mark the function as visible +* and add the marks according to the selection. + Notice that if the function has been marked as called by a visible top, + we can skip the selection since the function has to be fully visible anyway. +) +let select_pdg_elements proj pdg to_select = + let kf = PdgTypes.Pdg.get_kf pdg in + try KfTopVisi.find proj kf; + debug 1 "function '%a' selected for top: skip selection" + Kernel_function.pretty kf + with Not_found -> + debug 1 "add selection in function '%a'@." Kernel_function.pretty kf; + ProjBoolMarks.mark_and_propagate (proj_marks proj) pdg to_select; + List.iter (KfTopVisi.set proj) !called_top; + called_top := [] + +() +(** First step is finished: propagate in the calls. ) +() + ( [proj] contains some function marks and [!call_in_to_check] is a list of call input marks to propagate when the call is visible. * These marks come from the called function selection, @@ -152,20 +239,20 @@ | [] -> (to_select, unused) | (pdg_caller, call, sel, m) as e :: calls -> let kf_caller = PdgTypes.Pdg.get_kf pdg_caller in - let fm_caller = get_marks proj kf_caller in - let visible = match call with + let visible, select = match call with | Some call -> - let fm = match fm_caller with + let fm = match get_marks proj kf_caller with | None -> fatal "the caller should have marks@." - | Some fm -> fm + | Some fm -> fm in - call_visible fm call + let visible = call_visible fm call in + visible, Some (sel, m) | None -> (* let see if the function is visible or not ) assert (PdgTypes.Pdg.is_top pdg_caller); - match fm_caller with None -> false | Some _fm -> true + KfTopVisi.get proj kf_caller, None in let res = if visible then - let to_select = add_pdg_selection to_select pdg_caller (sel, m) + let to_select = add_pdg_selection to_select pdg_caller select in (to_select, unused) else (to_select, e::unused) in process res calls @@ -180,30 +267,28 @@ to_select; process_call_inputs proj +() +( Main selection: select starting points and propagate. ) +(**) -let add_node_to_select glob to_select z_opt node = - PdgMarks.add_node_to_select to_select (node, z_opt) (BoolMark.mk glob) +let select_entry_point proj _kf pdg = + let ctrl = !Db.Pdg.find_entry_point_node pdg in + let to_select = add_node_to_select true [] None ctrl in + select_pdg_elements proj pdg to_select -let add_nodes_and_undef_to_select - glob (ctrl_nodes, decl_nodes, data_info) to_select = - match data_info with - | None -> to_select (* don't select anything (computation failed) ) - | Some (data_nodes, undef) -> - let to_select = - List.fold_left (fun s n -> add_node_to_select glob s None n) - to_select ctrl_nodes - in - let to_select = - List.fold_left (fun s n -> add_node_to_select glob s None n) - to_select decl_nodes - in - let to_select = - List.fold_left (fun s (n,z_opt) -> add_node_to_select glob s z_opt n) - to_select data_nodes - in - let m = (BoolMark.mk glob) in - let to_select = PdgMarks.add_undef_in_to_select to_select undef m in - to_select +let select_all_outputs proj kf pdg = + let outputs = !Db.Outputs.get_external kf in + debug 1 "selecting output zones %a@." Locations.Zone.pretty outputs; + try + let nodes, undef = !Db.Pdg.find_location_nodes_at_end pdg outputs in + let nodes = + try ((!Db.Pdg.find_ret_output_node pdg),None) :: nodes + with Not_found -> nodes + in + let nodes_and_co = ([], [], Some (nodes, undef)) in + let to_select = add_nodes_and_undef_to_select false nodes_and_co [] in + select_pdg_elements proj pdg to_select + with Not_found -> ( end is unreachable *) () (** used to visit all the annotations of a given function * and to find the PDG nodes to select so that the reachable annotations @@ -221,71 +306,65 @@ if filter annot then try let stmt = Cilutil.valOf self#current_stmt in - let before = self#is_annot_before in - debug 1 "selecting annotation : %a @." - !Ast_printer.d_code_annotation annot; - let info = !Db.Pdg.find_code_annot_nodes pdg before stmt annot in + debug 1 "selecting annotation : %a @." + !Ast_printer.d_code_annotation annot; + let info = !Db.Pdg.find_code_annot_nodes pdg stmt annot in to_select <- add_nodes_and_undef_to_select true info to_select - with PdgIndex.NotFound -> () (* unreachable ) + with Not_found -> () ( unreachable ) in Cil.SkipChildren end -let select_all_outputs proj kf = - let pdg = !Db.Pdg.get kf in - let outputs = !Db.Outputs.get_external kf in - debug 1 "selecting output zones %a@." - Locations.Zone.pretty outputs; - try - let nodes, undef = !Db.Pdg.find_location_nodes_at_end pdg outputs in - let nodes = - try ((!Db.Pdg.find_ret_output_node pdg),None) :: nodes - with Db.Pdg.NotFound -> nodes - in - let nodes_and_co = ([], [], Some (nodes, undef)) in - let to_select = add_nodes_and_undef_to_select false nodes_and_co [] in - select_pdg_elements proj pdg to_select - with PdgIndex.NotFound -> ( end is unreachable ) - () - let select_annotations ~select_annot ~select_slice_pragma proj = let visit_fun kf = - try - debug 1 "look for annotations in function %s@." - (Kernel_function.get_name kf); - let filter annot = match annot.Cil_types.annot_content with - | Cil_types.APragma (Cil_types.Slice_pragma _) -> select_slice_pragma - | _ -> select_annot in - let f = Kernel_function.get_definition kf in - let pdg = !Db.Pdg.get kf in - let visit = new annot_visitor ~filter pdg in - ignore (Visitor.visitFramacFunction (visit:>Visitor.frama_c_visitor) f); - let to_select = visit#get_select in - select_pdg_elements proj pdg to_select - with Kernel_function.No_Definition -> - () ( nothing to do ) + debug 1 "look for annotations in function %a@." Kernel_function.pretty kf; + let pdg = !Db.Pdg.get kf in + if PdgTypes.Pdg.is_top pdg then debug 1 "pdg top: skip annotations" + else if PdgTypes.Pdg.is_bottom pdg + then debug 1 "pdg bottom: skip annotations" + else begin + let filter annot = match annot.Cil_types.annot_content with + | Cil_types.APragma (Cil_types.Slice_pragma _) -> select_slice_pragma + | _ -> select_annot + in + try + let f = Kernel_function.get_definition kf in + let visit = new annot_visitor ~filter pdg in + let fc_visit = (visit:>Visitor.frama_c_visitor) in + let _ = Visitor.visitFramacFunction fc_visit f in + let to_select = visit#get_select in + if to_select <> [] then select_pdg_elements proj pdg to_select + with Kernel_function.No_Definition -> () ( nothing to do ) + end in Globals.Functions.iter visit_fun -let select_entry_point proj kf = - let pdg = !Db.Pdg.get kf in - let ctrl = !Db.Pdg.find_entry_point_node pdg in - let to_select = add_node_to_select true [] None ctrl in - select_pdg_elements proj pdg to_select - let finalize proj = - debug 1 "finalize (process call inputs) @."; + debug 1 "finalize call input propagation@."; process_call_inputs proj; assert (!call_in_to_check = []) - -let select_usefull_things ~select_annot ~select_slice_pragma kf_entry = - let proj = ProjBoolMarks.empty in +let select_useful_things ~select_annot ~select_slice_pragma kf_entry = + let proj = new_project () in assert (!call_in_to_check = []); - debug 1 "selecting function %s outputs and entry point@." - (Kernel_function.get_name kf_entry); - select_entry_point proj kf_entry; - select_all_outputs proj kf_entry; - if (select_annot or select_slice_pragma) then - select_annotations ~select_annot ~select_slice_pragma proj; - finalize proj; + debug 1 "selecting function %a outputs and entry point@." + Kernel_function.pretty kf_entry; + let pdg = !Db.Pdg.get kf_entry in + if PdgTypes.Pdg.is_top pdg + then KfTopVisi.set proj kf_entry + else if PdgTypes.Pdg.is_bottom pdg + then debug 1 "unreachable entry point ?" + else begin + select_entry_point proj kf_entry pdg; + select_all_outputs proj kf_entry pdg; + if (select_annot || select_slice_pragma) then + select_annotations ~select_annot ~select_slice_pragma proj; + finalize proj + end; proj + +(~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/sparecode/marks.mli frama-c-20111001+nitrogen+dfsg/src/sparecode/marks.mli --- frama-c-20110201+carbon+dfsg/src/sparecode/marks.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/sparecode/marks.mli 2011-10-10 08:38:24.000000000 +0000 @@ -26,10 +26,19 @@ type t_fct -val select_usefull_things : - select_annot:bool -> select_slice_pragma:bool -> Db_types.kernel_function -> t_proj +val select_useful_things : + select_annot:bool -> select_slice_pragma:bool -> Cil_types.kernel_function + -> t_proj -val get_marks : t_proj -> Db_types.kernel_function -> t_fct option +val get_marks : t_proj -> Cil_types.kernel_function -> t_fct option val key_visible : t_fct -> PdgIndex.Key.t -> bool +(** Useful mainly if there has been some Pdg.Top ) +val kf_visible : t_proj -> Cil_types.kernel_function -> bool + +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/sparecode/register.ml frama-c-20111001+nitrogen+dfsg/src/sparecode/register.ml --- frama-c-20110201+carbon+dfsg/src/sparecode/register.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/sparecode/register.ml 2011-10-10 08:38:24.000000000 +0000 @@ -46,7 +46,7 @@ Cmdline.run_after_extended_stage (fun () -> State_dependency_graph.Static.add_codependencies - ~onto:Result.self + ~onto:Result.self [ !Db.Pdg.self; !Db.Outputs.self_external ]) module P = Sparecode_params @@ -66,10 +66,14 @@ ~label1:("new_proj_name", None) Datatype.string ~label2:("project", Some Project.current) Project.ty Project.ty) - unjournalized_rm_unused_globals + unjournalized_rm_unused_globals let rm_unused_globals ?new_proj_name ?(project=Project.current ()) () = - let new_proj_name = match new_proj_name with Some name -> name | None -> (Project.get_name project)^ " (without unused globals)" in + let new_proj_name = + match new_proj_name with + | Some name -> name + | None -> (Project.get_name project)^ " (without unused globals)" + in journalized_rm_unused_globals new_proj_name project let run select_annot select_slice_pragma = @@ -77,20 +81,22 @@ (let initial_file = Ast.get () in) let kf_entry, _library = Globals.entry_point () in - let proj = Marks.select_usefull_things - ~select_annot ~select_slice_pragma kf_entry in + let proj = + Marks.select_useful_things ~select_annot ~select_slice_pragma kf_entry + in let old_proj_name = Project.get_name (Project.current ()) in let new_proj_name = (old_proj_name^" without sparecode") in - P.feedback "remove unused global declarations..."; + P.feedback "remove unused global declarations..."; let tmp_prj = Transform.Info.build_cil_file "tmp_prj" proj in let new_prj = Project.on tmp_prj Globs.rm_unused_decl new_proj_name in - P.result "result in new project '%s'." (Project.get_name new_prj); - Project.remove ~project:tmp_prj (); - let ctx = Parameters.get_selection_context () in - Project.copy ~selection:ctx new_prj; - new_prj + + P.result "result in new project '%s'." (Project.get_name new_prj); + Project.remove ~project:tmp_prj (); + let ctx = Plugin.get_selection_context () in + Project.copy ~selection:ctx new_prj; + new_prj let journalized_get = Journal.register @@ -100,9 +106,9 @@ ~label2:("select_slice_pragma", None) Datatype.bool Project.ty) (fun select_annot select_slice_pragma -> - Result.memo - (fun _ -> run select_annot select_slice_pragma) - (select_annot, select_slice_pragma)) + Result.memo + (fun _ -> run select_annot select_slice_pragma) + (select_annot, select_slice_pragma)) ( add labels ) let get ~select_annot ~select_slice_pragma = @@ -131,7 +137,7 @@ let () = Db.Main.extend main ( -Local Variables: -compile-command: "make -C ../.." -End: + Local Variables: + compile-command: "make -C ../.." + End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/sparecode/sparecode_params.ml frama-c-20111001+nitrogen+dfsg/src/sparecode/sparecode_params.ml --- frama-c-20110201+carbon+dfsg/src/sparecode/sparecode_params.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/sparecode/sparecode_params.ml 2011-10-10 08:38:24.000000000 +0000 @@ -31,10 +31,11 @@ module Analysis = False(struct - let option_name = "-sparecode-analysis" + let option_name = "-sparecode" let help = "perform a spare code analysis" let kind = `Tuning end) +let () = Analysis.add_aliases ["-sparecode-analysis"] module Annot = True(struct @@ -50,3 +51,10 @@ "(automatically done by -sparecode-analysis)") let kind = `Correctness end) + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/sparecode/sparecode_params.mli frama-c-20111001+nitrogen+dfsg/src/sparecode/sparecode_params.mli --- frama-c-20110201+carbon+dfsg/src/sparecode/sparecode_params.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/sparecode/sparecode_params.mli 2011-10-10 08:38:24.000000000 +0000 @@ -24,12 +24,17 @@ include Plugin.S -module Analysis: Plugin.BOOL +module Analysis: Plugin.Bool (** Whether to perform spare code detection or not. *) -module Annot : Plugin.BOOL +module Annot : Plugin.Bool (** keep more things to keep all reachable annotations. *) -module GlobDecl : Plugin.BOOL +module GlobDecl : Plugin.Bool (** remove unused global types and variables ) +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/sparecode/transform.ml frama-c-20111001+nitrogen+dfsg/src/sparecode/transform.ml --- frama-c-20110201+carbon+dfsg/src/sparecode/transform.ml 2011-02-07 13:53:56.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/sparecode/transform.ml 2011-10-10 08:38:24.000000000 +0000 @@ -27,70 +27,60 @@ module BoolInfo = struct type t_proj = Marks.t_proj - type t_fct = Marks.t_fct Kernel_function.t + type t_fct = Marks.t_fct option * Kernel_function.t exception EraseAssigns let fct_info project kf = match Marks.get_marks project kf with - | None -> [] - | Some fm -> [fm,kf] + | None -> + if Marks.kf_visible project kf then [None, kf] else [] + | Some fm -> [Some fm, kf] let key_visible txt fm key = - let visible = Marks.key_visible fm key in - Sparecode_params.debug ~level:3 "%s : %a -> %s@\n" - txt !Db.Pdg.pretty_key key (if visible then "true" else "false"); - visible + let visible = match fm with None -> true + | Some fm -> Marks.key_visible fm key + in + Sparecode_params.debug ~level:3 "%s : %a -> %b" + txt !Db.Pdg.pretty_key key visible; + visible + + let param_visible (fm,_) n = + let key = PdgIndex.Key.param_key n in + key_visible "param_visible" fm key + + let loc_var_visible (fm,_) var = + let key = PdgIndex.Key.decl_var_key var in + key_visible "loc_var_visible" fm key let term_visible (fm,kf) t = let module M = struct exception Invisible end in - let visitor = - object - inherit Visitor.frama_c_inplace - method vlogic_var_use v = - match v.lv_origin with - None -> DoChildren - | Some v when v.vformal -> - (try - if not - (key_visible "logic_var_visible" fm - (PdgIndex.Key.param_key - (Kernel_function.get_formal_position v kf + 1) - v)) - then raise M.Invisible - else DoChildren - with Not_found -> - Sparecode_params.fatal - "%a is a formal parameter but not of the current \ - kernel function %a. Aborting because of inconsistent state." - !Ast_printer.d_var v !Ast_printer.d_var - (Kernel_function.get_vi kf) - ) - | Some v when not v.vglob -> - if - not - (key_visible "logic_var_visible" fm - (PdgIndex.Key.decl_var_key v)) + let visitor = object inherit Visitor.frama_c_inplace + method vlogic_var_use v = + match v.lv_origin with + | None -> DoChildren + | Some v when v.vformal -> + let n_param = Kernel_function.get_formal_position v kf + 1 in + if not (param_visible (fm,kf) n_param) + then raise M.Invisible + else DoChildren + | Some v when not v.vglob -> + if not (loc_var_visible (fm, kf) v) then raise M.Invisible else DoChildren - | Some _ -> DoChildren - end + | Some _ -> DoChildren + end in - try - ignore (Visitor.visitFramacTerm visitor t); true - with M.Invisible -> false + try ignore (Visitor.visitFramacTerm visitor t); true + with M.Invisible -> false let body_visible _fm = true - let param_visible (fm,_) n = - let key = PdgIndex.Key.param_key n () in - key_visible "param_visible" fm key - let label_visible (fm,_) stmt label = let lab_key = PdgIndex.Key.label_key stmt label in key_visible "label_visible" fm lab_key - let annotation_visible _ _stmt ~before:_ _annot = + let annotation_visible _ _stmt _annot = (* all the annotation should have been selected by the analysis ) true @@ -121,36 +111,45 @@ key_visible "res_call_visible" fm key - let called_info (project, _fm) call_stmt = match call_stmt.skind with - | Instr (Call (_, _fexp, _, _)) -> - let called_functions = Db.Value.call_to_kernel_function call_stmt in - (match Kernel_function.Hptset.contains_single_elt called_functions with - | None -> None - | Some funct -> - (match Marks.get_marks project funct with - | None -> None - | Some fm -> Some (funct, (fm,funct)))) - | _ -> - Sparecode_params.fatal "this call is not a call" + let called_info (project, _fm) call_stmt = + match call_stmt.skind with + | Instr (Call (_, _fexp, _, _)) -> + let called_functions = Db.Value.call_to_kernel_function call_stmt in + let call_info = + match + Kernel_function.Hptset.contains_single_elt called_functions + with + | None -> None + | Some kf -> + match Marks.get_marks project kf with + | None -> + if Marks.kf_visible project kf + then Some (kf, (None,kf)) + else None + | Some fm -> Some (kf, (Some fm,kf)) + in call_info + | _ -> Sparecode_params.fatal "this call is not a call" let inst_visible (fm,_) stmt = match stmt.Cil_types.skind with - | Cil_types.Block _ -> - ( block are always visible for syntactic reasons ) - true - | _ -> - let stmt_key = PdgIndex.Key.stmt_key stmt in - key_visible "inst_visible" fm stmt_key - - let loc_var_visible (fm,_) var = - let key = PdgIndex.Key.decl_var_key var in - key_visible "loc_var_visible" fm key + | Cil_types.Block _ -> ( block are always visible for syntactic reasons ) + true + | _ -> + let stmt_key = PdgIndex.Key.stmt_key stmt in + key_visible "inst_visible" fm stmt_key let fct_name v _fm = v.Cil_types.vname let result_visible kf fm_kf = try inst_visible fm_kf (Kernel_function.find_return kf) - with Kernel_function.No_Definition -> true + with Kernel_function.No_Statement -> true end module Info = Filter.F (BoolInfo) + + +( +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/cg_viewer.ml frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/cg_viewer.ml --- frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/cg_viewer.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/cg_viewer.ml 2011-10-10 08:38:30.000000000 +0000 @@ -55,16 +55,16 @@ ( itering on nodes of the current service ) List.iter (fun n -> - n#compute (); - if not (self#is_root n) then n#show (); - view#iter_succ_e - (fun e -> match self#edge_kind e with - | Service.Inter_functions | Service.Both -> - e#compute (); - e#show () - | Service.Inter_services -> - e#hide ()) - n) + n#compute (); + if not (self#is_root n) then n#show (); + view#iter_succ_e + (fun e -> match self#edge_kind e with + | Service.Inter_functions | Service.Both -> + e#compute (); + e#show () + | Service.Inter_services -> + e#hide ()) + n) !nodes method undeploy node = @@ -76,12 +76,12 @@ ( itering on nodes of the current service ) List.iter (fun n -> - if not (self#is_root n) then n#hide (); - view#iter_succ_e - (fun e -> match self#edge_kind e with - | Service.Inter_services | Service.Both -> e#show () - | Service.Inter_functions -> e#hide ()) - n) + if not (self#is_root n) then n#hide (); + view#iter_succ_e + (fun e -> match self#edge_kind e with + | Service.Inter_services | Service.Both -> e#show () + | Service.Inter_functions -> e#hide ()) + n) !nodes method service n = n#item.Service.root.Service.node.Callgraph.cnid @@ -97,11 +97,11 @@ let connect_trigger_to_node n = let callback = function | `BUTTON_PRESS _ -> - if self#is_deployed (self#service n) then self#undeploy n - else self#deploy n; - false + if self#is_deployed (self#service n) then self#undeploy n + else self#deploy n; + false | _ -> - false + false in n#connect_event ~callback in @@ -139,27 +139,27 @@ let width = int_of_float (float parent#default_width . 3. /. 4.) in let window = GWindow.window - ~position:`CENTER - ~height ~width ~title:"Syntactic Callgraph" - ~allow_shrink:true ~allow_grow:true () + ~position:`CENTER + ~height ~width ~title:"Syntactic Callgraph" + ~allow_shrink:true ~allow_grow:true () in let _, view = View.from_graph_with_commands - ~packing:window#add - ~root:(Service.entry_point ()) - ~mk_global_view:services_view - graph + ~packing:window#add + ?root:(Service.entry_point ()) + ~mk_global_view:services_view + graph in window#show (); view#adapt_zoom () - with DGraphModel.DotError cmd -> - main_window#error "%s failed\n" cmd + with DGraphModel.DotError cmd -> main_window#error "%s\n" cmd let main (window: Design.main_window_extension_points) = ignore ((window#menu_manager ())#add_plugin - [ Menu_manager.Menubar(None, "Show callgraph"), - (fun () -> graph_window window) ]) + [ Menu_manager.menubar "Show callgraph" + (Menu_manager.Unit_callback (fun () -> graph_window window)); + ]) let () = Design.register_extension main diff -Nru frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/options.ml frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/options.ml --- frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/options.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/options.ml 2011-10-10 08:38:30.000000000 +0000 @@ -37,7 +37,7 @@ let arg_name = "filename" let help = "dump the syntactic stratified callgraph to the file \ <filename> in dot format" - let kind = `Tuning + let kind = Parameter.Other end) module InitFunc = @@ -46,7 +46,7 @@ let option_name = "-cg-init-func" let arg_name = "" let help = "use the given functions as a root service for the callgraph (you can add as many comma-separated functions as you want; if no function is declared, then root services are initialized with functions with no callers)" - let kind = `Correctness + let kind = Parameter.Correctness end) module ServicesOnly = @@ -54,7 +54,7 @@ (struct let option_name = "-cg-services-only" let help = "only computes the graph of services" - let kind = `Tuning + let kind = Parameter.Other end) (* diff -Nru frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/options.mli frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/options.mli --- frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/options.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/options.mli 2011-10-10 08:38:30.000000000 +0000 @@ -23,10 +23,10 @@ include Plugin.S val name: string -module Filename: Plugin.STRING -module InitFunc: Plugin.STRING_SET +module Filename: Plugin.String +module InitFunc: Plugin.String_set -module ServicesOnly: Plugin.BOOL +module ServicesOnly: Plugin.Bool (** @since Beryllium-20090901 ) ( diff -Nru frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/register.ml frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/register.ml --- frama-c-20110201+carbon+dfsg/src/syntactic_callgraph/register.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/syntactic_callgraph/register.ml 2011-10-10 08:38:30.000000000 +0000 @@ -25,7 +25,6 @@ open Callgraph open Options - let entry_point_ref = ref None module Service = @@ -41,11 +40,9 @@ [ match v.cnInfo with | NIVar (_,b) when not !b -> `Style `Dotted | _ -> `Style `Bold ] - let equal v1 v2 = id v1 = id v2 - let hash = id - let entry_point () = match !entry_point_ref with - | None -> assert false - | Some v -> v + let equal v1 v2 = id v1 = id v2 + let hash = id + let entry_point () = !entry_point_ref end let iter_vertex f = Hashtbl.iter (fun _ -> f) let iter_succ f _g v = Inthash.iter (fun _ -> f) v.cnCallees @@ -63,37 +60,42 @@ let kind = `Correctness end) -let get_init_funcs cg = - (* already checked that this entry point is ok ) - let entry_point_name = Parameters.MainFunction.get () in - let init_funcs = ( entry point is always a root ) - Datatype.String.Set.add entry_point_name (InitFunc.get ()) - in - ( Add the callees of entry point as roots ) - Datatype.String.Set.union - (try - let callees = (Hashtbl.find cg entry_point_name).Callgraph.cnCallees in - Inthash.fold - (fun _ v acc -> match v.Callgraph.cnInfo with - | Callgraph.NIVar ({vname=n},_) -> Datatype.String.Set.add n acc - | _ -> acc) - callees - Datatype.String.Set.empty - with Not_found -> - Datatype.String.Set.empty) - init_funcs +let get_init_funcs main_name cg = + match main_name with + | None -> InitFunc.get () + | Some s -> + ( the entry point is always a root ) + let init_funcs = Datatype.String.Set.add s (InitFunc.get ()) in + ( Add the callees of entry point as roots ) + Datatype.String.Set.union + (try + let callees = (Hashtbl.find cg s).Callgraph.cnCallees in + Inthash.fold + (fun _ v acc -> match v.Callgraph.cnInfo with + | Callgraph.NIVar ({vname=n},_) -> Datatype.String.Set.add n acc + | _ -> acc) + callees + Datatype.String.Set.empty + with Not_found -> + Datatype.String.Set.empty) + init_funcs let compute () = feedback "beginning analysis"; let p = Ast.get () in - ( fixes bts#587: check that Parameters.MainFunction.get is valid. ) - ignore (Globals.entry_point ()); let cg = computeGraph p in - entry_point_ref := - Some - (try Hashtbl.find cg (Parameters.MainFunction.get ()) - with Not_found -> assert false); - let init_funcs = get_init_funcs cg in + let main = Kernel.MainFunction.get () in + let main_name = + try + entry_point_ref := Some (Hashtbl.find cg main); + Some main + with Not_found -> + warning "no entry point available: services could be less precise. \ +Use option `-main' to improve them."; + entry_point_ref := None; + None + in + let init_funcs = get_init_funcs main_name cg in let cg = Service.compute cg init_funcs in CG.mark_as_computed (); feedback "analysis done"; @@ -145,6 +147,6 @@ ( Local Variables: -compile-command: "LC_ALL=C make -C ../.." +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/toplevel/toplevel_topdirs.ml frama-c-20111001+nitrogen+dfsg/src/toplevel/toplevel_topdirs.ml --- frama-c-20110201+carbon+dfsg/src/toplevel/toplevel_topdirs.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/toplevel/toplevel_topdirs.ml 2011-10-10 08:38:28.000000000 +0000 @@ -20,7 +20,7 @@ ( *) (**************************************************************************) -let top = +let top = let dir_bin = Filename.dirname Sys.executable_name in Filename.concat dir_bin ".." @@ -28,15 +28,14 @@ let abs_dir = Filename.concat top dir in Topdirs.dir_directory abs_dir -let src_dir = +let src_dir = [ "ai"; "buckx"; "constant_propagation"; "cxx_types"; "from"; "gui"; "impact"; "inout"; "jessie"; "journal"; "kernel"; "lib"; "logic"; "memory_state"; "misc"; "modular_dependencies"; "occurrence"; - "pdg"; "pdg_types"; "phantom"; "postdominators"; "project"; "scope"; - "security"; "semantic_callgraph"; "slicing"; "slicing_types"; "sparecode"; + "pdg"; "pdg_types"; "phantom"; "postdominators"; "project"; "scope"; + "security"; "semantic_callgraph"; "slicing"; "slicing_types"; "sparecode"; "toplevel"; "users"; "value"; "wp" ] -let () = +let () = List.iter (fun s -> add_top (Filename.concat "src" s)) src_dir; add_top "external" - diff -Nru frama-c-20110201+carbon+dfsg/src/type/datatype.ml frama-c-20111001+nitrogen+dfsg/src/type/datatype.ml --- frama-c-20110201+carbon+dfsg/src/type/datatype.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/type/datatype.ml 2011-10-10 08:38:09.000000000 +0000 @@ -70,22 +70,26 @@ module Infos = Type.Ty_tbl(struct type 'a t = 'a info end) let info_tbl = Infos.create 97 -let info ty = + +let internal_info s ty = try Infos.find info_tbl ty with Not_found -> - Format.eprintf "Internal Datatype.info error: no info for %S@." - (Type.name ty); + Format.eprintf "Internal Datatype.info error: no %s for %S@." + s (Type.name ty); assert false -let equal ty = (info ty).equal -let compare ty = (info ty).compare -let hash ty = (info ty).hash -let copy ty = (info ty).copy -let internal_pretty_code ty = (info ty).internal_pretty_code -let pretty_code ty = (info ty).pretty_code -let pretty ty = (info ty).pretty -let varname ty = (info ty).varname -let mem_project ty = (info ty).mem_project +let equal ty = (internal_info "equal" ty).equal +let compare ty = (internal_info "compare" ty).compare +let hash ty = (internal_info "hash" ty).hash +let copy ty = (internal_info "copy" ty).copy +let internal_pretty_code ty = + (internal_info "internal_pretty_code" ty).internal_pretty_code +let pretty_code ty = (internal_info "pretty_code" ty).pretty_code +let pretty ty = (internal_info "pretty" ty).pretty +let varname ty = (internal_info "varname" ty).varname +let mem_project ty = (internal_info "mem_project" ty).mem_project + +let info ty = internal_info "info" ty (* ********************************************************************** *) (** {2 Easy builders} ) @@ -145,18 +149,19 @@ let check f fname tname fstr = assert - (if f == undefined then begin + (if f == undefined && Type.may_use_obj () then begin Format.printf "@[Preliminary datatype check failed.@\n\ Value `%s' of type %s is required for building %s.@]@." - fname tname fstr; + fname tname fstr; false end else - true) + true) module Build (T: sig type t val ty: t Type.t + val reprs: t list val equal: t -> t -> bool val compare: t -> t -> int val hash: t -> int @@ -221,25 +226,27 @@ let mk_full_descr d = let descr = if rehash == undefined then - if Descr.is_unmarshable d then Descr.unmarshable - else begin - check rehash "rehash" name "descriptor"; - assert false - end + if Descr.is_unmarshable d then Descr.unmarshable + else begin + check rehash "rehash" name "descriptor"; + assert false + end else - if rehash == identity then d - else begin - if Descr.is_unmarshable d then begin - check undefined "structural_descr" name "descriptor"; - assert false - end; - Descr.transform d rehash - end + if rehash == identity then d + else + if Type.may_use_obj () then begin + if Descr.is_unmarshable d then begin + check undefined "structural_descr" name "descriptor"; + assert false + end; + Descr.transform d rehash + end else + Descr.unmarshable in descr, Descr.pack descr let descr, packed_descr = mk_full_descr (Descr.of_type T.ty) - let reprs = Type.reprs T.ty + let reprs = T.reprs ( [Type.reprs] is not usable in the "no-obj" mode ) end @@ -294,13 +301,14 @@ end module type Map = sig - include Map.S + include Map_common_interface.S module Key: S with type t = key module Make(Data: S) : S with type t = Data.t t end module type Hashtbl = sig include Hashtbl.S + val memo: 'a t -> key -> (key -> 'a) -> 'a module Key: S with type t = key module Make(Data: S) : S with type t = Data.t t end @@ -369,47 +377,53 @@ include T include Build (struct - include T - let build mk f1 f2 = - if mk == undefined || f1 == undefined || f2 == undefined then - undefined - else - mk f1 f2 - let compare = build P.mk_compare T1.compare T2.compare - let equal = build P.mk_equal T1.equal T2.equal - let hash = build P.mk_hash T1.hash T2.hash - let rehash = identity - let copy = - let mk f1 f2 = - if P.map == undefined then undefined - else if f1 == identity && f2 == identity then identity - else P.map f1 f2 - in - build mk T1.copy T2.copy - let internal_pretty_code = + include T + let reprs = + if Type.may_use_obj () then Type.reprs ty + else P.reprs (List.hd T1.reprs) (List.hd T2.reprs) + let build mk f1 f2 = + if mk == undefined || f1 == undefined || f2 == undefined then + undefined + else + mk f1 f2 + let compare = build P.mk_compare T1.compare T2.compare + let equal = build P.mk_equal T1.equal T2.equal + let hash = build P.mk_hash T1.hash T2.hash + let rehash = identity + let copy = + let mk f1 f2 = + if P.map == undefined then undefined + else + ( [JS 2011/05/31] No optimisation for the special case of identity, + since we really want to perform a DEEP copy. ) + (if f1 == identity && f2 == identity then identity + else) P.map f1 f2 + in + build mk T1.copy T2.copy + let internal_pretty_code = let mk f1 f2 = if f1 == pp_fail || f2 == pp_fail then pp_fail else fun p fmt x -> P.mk_internal_pretty_code f1 f2 p fmt x in - build mk T1.internal_pretty_code T2.internal_pretty_code - let pretty = build P.mk_pretty T1.pretty T2.pretty - let varname = build P.mk_varname T1.varname T2.varname - let mem_project = - let mk f1 f2 = - if P.mk_mem_project == undefined then undefined - else if f1 == never_any_project && f2 == never_any_project then - never_any_project - else - P.mk_mem_project f1 f2 - in - build mk T1.mem_project T2.mem_project + build mk T1.internal_pretty_code T2.internal_pretty_code + let pretty = build P.mk_pretty T1.pretty T2.pretty + let varname = build P.mk_varname T1.varname T2.varname + let mem_project = + let mk f1 f2 = + if P.mk_mem_project == undefined then undefined + else if f1 == never_any_project && f2 == never_any_project then + never_any_project + else + P.mk_mem_project f1 f2 + in + build mk T1.mem_project T2.mem_project end) let descr, packed_descr = mk_full_descr - (Descr.of_structural - ty - (P.structural_descr (Descr.str T1.descr) (Descr.str T2.descr))) + (Descr.of_structural + ty + (P.structural_descr (Descr.str T1.descr) (Descr.str T2.descr))) end @@ -434,7 +448,7 @@ let mk_internal_pretty_code f1 f2 p fmt (x1, x2) = let pp fmt = Format.fprintf - fmt "@[<hv 2>%a,@;%a@]" (f1 Type.Tuple) x1 (f2 Type.Tuple) x2 + fmt "@[<hv 2>%a,@;%a@]" (f1 Type.Tuple) x1 (f2 Type.Tuple) x2 in Type.par p Type.Tuple fmt pp let mk_pretty f1 f2 fmt p = @@ -449,9 +463,9 @@ let name ty1 ty2 = let arg ty = Type.par_ty_name - (fun ty -> - Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty) - ty + (fun ty -> + Type.Function.is_instance_of ty || Poly_pair.is_instance_of ty) + ty in arg ty1 ^ " " ^ arg ty2 end @@ -510,6 +524,8 @@ let pretty = undefined let varname _ = "f" let mem_project = never_any_project + let reprs = + if Type.may_use_obj () then Type.reprs ty else [ fun _ -> assert false ] end include T include Build(T) @@ -566,39 +582,46 @@ include Build (struct - include T - let build mk f = - if mk == undefined || f == undefined then undefined else mk f - let compare = build P.mk_compare X.compare - let equal = build P.mk_equal X.equal - let hash = build P.mk_hash X.hash - let copy = - let mk f = - if P.map == undefined then undefined - else if f == identity then identity else fun x -> P.map f x - in - build mk X.copy - let rehash = identity - let internal_pretty_code = + include T + let build mk f = + if mk == undefined || f == undefined then undefined else mk f + let compare = build P.mk_compare X.compare + let equal = build P.mk_equal X.equal + let hash = build P.mk_hash X.hash + let copy = + let mk f = + if P.map == undefined then undefined + else + (* [JS 2011/05/31] No optimisation for the special case of + identity, since we really want to perform a DEEP copy. ) + (if f == identity then identity else) + fun x -> P.map f x + in + build mk X.copy + let rehash = identity + let internal_pretty_code = let mk f = if f == pp_fail then pp_fail else fun p fmt x -> P.mk_internal_pretty_code f p fmt x in - build mk X.internal_pretty_code - let pretty = build P.mk_pretty X.pretty - let varname = build P.mk_varname X.varname - let mem_project = - let mk f = - if P.mk_mem_project == undefined then undefined - else if f == never_any_project then never_any_project - else fun p x -> P.mk_mem_project f p x - in - build mk X.mem_project + build mk X.internal_pretty_code + let pretty = build P.mk_pretty X.pretty + let varname = build P.mk_varname X.varname + let mem_project = + let mk f = + if P.mk_mem_project == undefined then undefined + else if f == never_any_project then never_any_project + else fun p x -> P.mk_mem_project f p x + in + build mk X.mem_project + let reprs = + if Type.may_use_obj () then Type.reprs ty + else P.reprs (List.hd X.reprs) end) let descr, packed_descr = mk_full_descr - (Descr.of_structural ty (P.structural_descr (Descr.str X.descr))) + (Descr.of_structural ty (P.structural_descr (Descr.str X.descr))) end @@ -621,10 +644,10 @@ let mk_hash f x = f !x let map f x = ref (f !x) let mk_internal_pretty_code f p fmt x = - let pp fmt = Format.fprintf fmt "@[<hv 2>ref@;%a@]" (f Type.Call) !x in - Type.par p Type.Call fmt pp + let pp fmt = Format.fprintf fmt "@[<hv 2>ref@;%a@]" (f Type.Call) !x in + Type.par p Type.Call fmt pp let mk_pretty f fmt x = - mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x + mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x let mk_varname = undefined let mk_mem_project mem f x = mem f !x end) @@ -645,27 +668,27 @@ let reprs ty = [ Some ty ] let structural_descr = Structural_descr.t_option let mk_equal f x y = match x, y with - | None, None -> true - | None, Some _ | Some _, None -> false - | Some x, Some y -> f x y + | None, None -> true + | None, Some _ | Some _, None -> false + | Some x, Some y -> f x y let mk_compare f x y = - if x == y then 0 - else match x, y with - | None, None -> 0 - | None, Some _ -> 1 - | Some _, None -> -1 - | Some x, Some y -> f x y + if x == y then 0 + else match x, y with + | None, None -> 0 + | None, Some _ -> 1 + | Some _, None -> -1 + | Some x, Some y -> f x y let mk_hash f = function None -> 0 | Some x -> f x let map f = function None -> None | Some x -> Some (f x) let mk_internal_pretty_code f p fmt = function - | None -> Format.fprintf fmt "None" - | Some x -> - let pp fmt = - Format.fprintf fmt "@[<hv 2>Some@;%a@]" (f Type.Call) x - in - Type.par p Type.Call fmt pp + | None -> Format.fprintf fmt "None" + | Some x -> + let pp fmt = + Format.fprintf fmt "@[<hv 2>Some@;%a@]" (f Type.Call) x + in + Type.par p Type.Call fmt pp let mk_pretty f fmt x = - mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x + mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x let mk_varname = undefined let mk_mem_project mem f = function None -> false | Some x -> mem f x end) @@ -686,32 +709,32 @@ let reprs ty = [ [ ty ] ] let structural_descr = Structural_descr.t_list let mk_equal f l1 l2 = - try List.for_all2 f l1 l2 with Invalid_argument _ -> false + try List.for_all2 f l1 l2 with Invalid_argument _ -> false let rec mk_compare f l1 l2 = - if l1 == l2 then 0 - else match l1, l2 with - | [], [] -> assert false - | [], _ :: _ -> -1 - | _ :: _, [] -> 1 - | x1 :: q1, x2 :: q2 -> - let n = f x1 x2 in - if n = 0 then mk_compare f q1 q2 else n + if l1 == l2 then 0 + else match l1, l2 with + | [], [] -> assert false + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | x1 :: q1, x2 :: q2 -> + let n = f x1 x2 in + if n = 0 then mk_compare f q1 q2 else n let mk_hash f = List.fold_left (fun acc d -> 257 acc + f d) 1 let map = List.map let mk_internal_pretty_code f p fmt l = - let pp fmt = - Format.fprintf fmt "@[<hv 2>[ %t ]@]" - (fun fmt -> - let rec print fmt = function - | [] -> () - | [ x ] -> Format.fprintf fmt "%a" (f Type.List) x - | x :: l -> Format.fprintf fmt "%a;@;%a" (f Type.List) x print l - in - print fmt l) - in - Type.par p Type.Basic fmt pp (* Never enclose lists in parentheses ) + let pp fmt = + Format.fprintf fmt "@[<hv 2>[ %t ]@]" + (fun fmt -> + let rec print fmt = function + | [] -> () + | [ x ] -> Format.fprintf fmt "%a" (f Type.List) x + | x :: l -> Format.fprintf fmt "%a;@;%a" (f Type.List) x print l + in + print fmt l) + in + Type.par p Type.Basic fmt pp ( Never enclose lists in parentheses ) let mk_pretty f fmt x = - mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x + mk_internal_pretty_code (fun _ -> f) Type.Basic fmt x let mk_varname = undefined let mk_mem_project mem f = List.exists (mem f) end) @@ -760,9 +783,9 @@ let name ty = Type.par_ty_name is_function_or_pair ty ^ " Queue.t" let module_name = "Datatype.Queue" let reprs x = - let q = Queue.create () in - Queue.add x q; - [ q ] + let q = Queue.create () in + Queue.add x q; + [ q ] let structural_descr = Structural_descr.t_queue let mk_equal = undefined let mk_compare = undefined @@ -772,8 +795,8 @@ let mk_pretty = undefined let mk_varname = undefined let mk_mem_project mem f q = - try Queue.iter (fun x -> if mem f x then raise Exit) q; false - with Exit -> true + try Queue.iter (fun x -> if mem f x then raise Exit) q; false + with Exit -> true end) module Queue = Poly_queue.Make @@ -798,44 +821,45 @@ type t = S.t let name = Info.module_name ^ "(" ^ E.name ^ ")" let structural_descr = - Structural_descr.t_set_unchanged_compares (Descr.str E.descr) + Structural_descr.t_set_unchanged_compares (Descr.str E.descr) open S - let reprs = - empty :: Caml_list.map (fun r -> singleton r) (Type.reprs E.ty) + let reprs = empty :: Caml_list.map (fun r -> singleton r) E.reprs let compare = S.compare let equal = S.equal let hash = Hashtbl.hash ( Don't know how to do better ) let rehash = identity let copy = - if E.copy == identity then identity - else fun s -> S.fold (fun x -> S.add (E.copy x)) s S.empty + ( [JS 2011/05/31] No optimisation for the special case of + identity, since we really want to perform a DEEP copy. ) +( if E.copy == identity then identity + else*) fun s -> S.fold (fun x -> S.add (E.copy x)) s S.empty let internal_pretty_code p_caller fmt s = - if is_empty s then - Format.fprintf fmt "%s.empty" Info.module_name - else - let pp fmt = - if S.cardinal s = 1 then - Format.fprintf fmt "@[<hv 2>%s.singleton@;%a@]" - Info.module_name - (E.internal_pretty_code Type.Call) - (Caml_list.hd (S.elements s)) - else - Format.fprintf fmt - "@[<hv 2>List.fold_left@;\ + if is_empty s then + Format.fprintf fmt "%s.empty" Info.module_name + else + let pp fmt = + if S.cardinal s = 1 then + Format.fprintf fmt "@[<hv 2>%s.singleton@;%a@]" + Info.module_name + (E.internal_pretty_code Type.Call) + (Caml_list.hd (S.elements s)) + else + Format.fprintf fmt + "@[<hv 2>List.fold_left@;\ (fun acc s -> %s.add s acc)@;%s.empty@;%a@]" - Info.module_name - Info.module_name - (let module L = List(E) in L.internal_pretty_code Type.Call) - (S.elements s) - in - Type.par p_caller Type.Call fmt pp + Info.module_name + Info.module_name + (let module L = List(E) in L.internal_pretty_code Type.Call) + (S.elements s) + in + Type.par p_caller Type.Call fmt pp let pretty = from_pretty_code let varname = undefined let mem_project p s = - try S.iter (fun x -> if E.mem_project p x then raise Exit) s; false - with Exit -> true + try S.iter (fun x -> if E.mem_project p x then raise Exit) s; false + with Exit -> true end) include S @@ -860,9 +884,8 @@ (** {3 Map} ) ( ****************************************************************************) -module Initial_caml_map = Map - -module Map(M: Map.S)(Key: S with type t = M.key)(Info: Functor_info) = struct +module Map(M: Map_common_interface.S) + (Key: S with type t = M.key)(Info: Functor_info) = struct let () = check Key.equal "equal" Key.name Info.module_name let () = check Key.compare "compare" Key.name Info.module_name @@ -871,44 +894,67 @@ (struct type 'a t = 'a M.t let name ty = - Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")" + Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")" let structural_descr d = - Structural_descr.t_map_unchanged_compares (Descr.str Key.descr) d + Structural_descr.t_map_unchanged_compares (Descr.str Key.descr) d let module_name = Info.module_name open M let reprs r = - [ Caml_list.fold_left (fun m k -> add k r m) empty Key.reprs ] + [ Caml_list.fold_left (fun m k -> add k r m) empty Key.reprs ] let mk_compare = M.compare let mk_equal = M.equal let mk_hash = undefined let map = M.map let mk_internal_pretty_code = undefined + (f_value p_caller fmt map = + ( [JS 2011/04/01] untested code! ) + let pp_empty fmt = Format.fprintf fmt "%s.empty" Info.module_name in + if M.is_empty map then + Type.par p_caller Type.Basic fmt pp_empty + else + let pp fmt = + Format.fprintf + fmt "@[<hv 2>@[<hv 2>let map =@;%t@;<1 -2>in@]" pp_empty; + M.iter + (fun k v -> + Format.fprintf + fmt + "@[<hv 2>let map =@;%s.add@;@[<hv 2>map@;%a@;%a@]@;<1 -2>in@]" + Info.module_name + (Key.internal_pretty_code Type.Call) k + (f_value Type.Call) v) + map; + Format.fprintf fmt "@[map@]@]" + in + Type.par p_caller Type.Call fmt pp) let mk_pretty f_value fmt map = - Format.fprintf fmt "@[{{ "; - M.iter - (fun k v -> + Format.fprintf fmt "@[{{ "; + M.iter + (fun k v -> Format.fprintf fmt "@[@[%a@] -> @[%a@]@];@ " - Key.pretty k - f_value v) - map; - Format.fprintf fmt " }}@]" - let mk_varname = undefined + Key.pretty k + f_value v) + map; + Format.fprintf fmt " }}@]" + let mk_varname _ = + if Key.varname == undefined then undefined + else fun _ -> Format.sprintf "%s_map" Key.name let mk_mem_project = - if Key.mem_project == undefined then undefined - else - fun mem -> - if mem == never_any_project && Key.mem_project == never_any_project - then never_any_project - else - fun p m -> - try - M.iter - (fun k v -> - if Key.mem_project p k || mem p v then raise Exit) - m; - false - with Exit -> - true + if Key.mem_project == undefined then undefined + else + fun mem -> + if mem == never_any_project && Key.mem_project == never_any_project + then never_any_project + else + fun p m -> + try + M.iter + (fun k v -> + if Key.mem_project p k || mem p v then raise Exit) + m; + false + with Exit -> + true end) include M @@ -934,14 +980,14 @@ (struct type 'a t = 'a H.t let name ty = - Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")" + Info.module_name ^ "(" ^ Key.name ^ ", " ^ Type.name ty ^ ")" let module_name = Info.module_name let structural_descr d = - Structural_descr.t_hashtbl_unchanged_hashs (Descr.str Key.descr) d + Structural_descr.t_hashtbl_unchanged_hashs (Descr.str Key.descr) d open Hashtbl let reprs x = - [ let h = H.create 7 in - Caml_list.iter (fun k -> H.add h k x) Key.reprs; h ] + [ let h = H.create 7 in + Caml_list.iter (fun k -> H.add h k x) Key.reprs; h ] let mk_compare = undefined let mk_equal = from_compare let mk_hash = undefined @@ -958,24 +1004,32 @@ let mk_pretty = from_pretty_code let mk_varname = undefined let mk_mem_project = - if Key.mem_project == undefined then undefined - else - fun mem -> - if mem == never_any_project && Key.mem_project == never_any_project - then never_any_project - else - fun p m -> - try - H.iter - (fun k v -> - if Key.mem_project p k || mem p v then raise Exit) - m; - false - with Exit -> - true + if Key.mem_project == undefined then undefined + else + fun mem -> + if mem == never_any_project && Key.mem_project == never_any_project + then never_any_project + else + fun p m -> + try + H.iter + (fun k v -> + if Key.mem_project p k || mem p v then raise Exit) + m; + false + with Exit -> + true end) include H + + let memo tbl k f = + try find tbl k + with Not_found -> + let v = f k in + add tbl k v; + v + module Key = Key module Make = P.Make @@ -1030,7 +1084,7 @@ module Map = Map - (Initial_caml_map.Make(D)) + (Map_common_interface.Make(D)) (D) (struct let module_name = Info.module_name ^ ".Map" end) @@ -1248,14 +1302,13 @@ module Big_int = Make_with_collections (struct - open Big_int - type t = big_int + type t = My_bigint.t let name = "Datatype.Big_int" - let reprs = [ zero_big_int ] + let reprs = [ My_bigint.zero ] let structural_descr = Structural_descr.Abstract - let equal = eq_big_int - let compare = compare_big_int - let hash = Initial_caml_hashtbl.hash + let equal = My_bigint.equal + let compare = My_bigint.compare + let hash = My_bigint.hash let rehash = identity let copy = identity let internal_pretty_code par fmt n = @@ -1263,10 +1316,10 @@ Format.fprintf fmt "Big_int.big_int_of_string %S" - (Big_int.string_of_big_int n) + (My_bigint.to_string n) in Type.par par Type.Call fmt pp - let pretty fmt n = Format.fprintf fmt "%s" (Big_int.string_of_big_int n) + let pretty = My_bigint.pretty ~hexa:false let varname _ = "big_n" let mem_project = never_any_project end) @@ -1278,81 +1331,81 @@ type t = T1.t * T2.t * T3.t let name = "(" ^ T1.name ^ ", " ^ T2.name ^ ", " ^ T3.name ^ ")" let reprs = - Caml_list.fold_left - (fun acc x1 -> - Caml_list.fold_left - (fun acc x2 -> - Caml_list.fold_left - (fun acc x3 -> (x1, x2, x3) :: acc) - acc - T3.reprs) - acc - T2.reprs) - [] - T1.reprs + Caml_list.fold_left + (fun acc x1 -> + Caml_list.fold_left + (fun acc x2 -> + Caml_list.fold_left + (fun acc x3 -> (x1, x2, x3) :: acc) + acc + T3.reprs) + acc + T2.reprs) + [] + T1.reprs let structural_descr = - Structural_descr.t_tuple - [| T1.packed_descr; T2.packed_descr; T3.packed_descr |] + Structural_descr.t_tuple + [| T1.packed_descr; T2.packed_descr; T3.packed_descr |] let equal = - if T1.equal == undefined - || T2.equal == undefined - || T3.equal == undefined - then undefined - else - fun (x1, x2, x3) (y1, y2, y3) -> - T1.equal x1 y1 && T2.equal x2 y2 && T3.equal x3 y3 + if T1.equal == undefined + || T2.equal == undefined + || T3.equal == undefined + then undefined + else + fun (x1, x2, x3) (y1, y2, y3) -> + T1.equal x1 y1 && T2.equal x2 y2 && T3.equal x3 y3 let compare = - if T1.compare == undefined - || T2.compare == undefined - || T3.compare == undefined - then undefined - else - fun (x1, x2, x3 as x) (y1, y2, y3 as y) -> - if x == y then 0 - else - let n = T1.compare x1 y1 in - if n = 0 then - let n = T2.compare x2 y2 in - if n = 0 then T3.compare x3 y3 else n - else n + if T1.compare == undefined + || T2.compare == undefined + || T3.compare == undefined + then undefined + else + fun (x1, x2, x3 as x) (y1, y2, y3 as y) -> + if x == y then 0 + else + let n = T1.compare x1 y1 in + if n = 0 then + let n = T2.compare x2 y2 in + if n = 0 then T3.compare x3 y3 else n + else n let hash = - if T1.hash == undefined || T2.hash == undefined || T3.hash == undefined - then undefined - else - fun (x1, x2, x3) -> - Initial_caml_hashtbl.hash (T1.hash x1, T2.hash x2, T3.hash x3) + if T1.hash == undefined || T2.hash == undefined || T3.hash == undefined + then undefined + else + fun (x1, x2, x3) -> + Initial_caml_hashtbl.hash (T1.hash x1, T2.hash x2, T3.hash x3) let copy = - if T1.copy == undefined || T2.copy == undefined || T3.copy == undefined - then undefined - else fun (x1, x2, x3) -> T1.copy x1, T2.copy x2, T3.copy x3 + if T1.copy == undefined || T2.copy == undefined || T3.copy == undefined + then undefined + else fun (x1, x2, x3) -> T1.copy x1, T2.copy x2, T3.copy x3 let rehash = identity let varname = undefined let mem_project = - if T1.mem_project == undefined - || T2.mem_project == undefined - || T3.mem_project == undefined - then undefined - else - if T1.mem_project == never_any_project - && T2.mem_project == never_any_project - && T3.mem_project == never_any_project - then never_any_project - else - fun f (x1, x2, x3) -> - T1.mem_project f x1 && T2.mem_project f x2 && T3.mem_project f x3 - let pretty = undefined + if T1.mem_project == undefined + || T2.mem_project == undefined + || T3.mem_project == undefined + then undefined + else + if T1.mem_project == never_any_project + && T2.mem_project == never_any_project + && T3.mem_project == never_any_project + then never_any_project + else + fun f (x1, x2, x3) -> + T1.mem_project f x1 && T2.mem_project f x2 && T3.mem_project f x3 + let pretty = from_pretty_code let internal_pretty_code = - if T1.internal_pretty_code == undefined - || T2.internal_pretty_code == undefined - || T3.internal_pretty_code == undefined - then undefined - else - if T1.internal_pretty_code == pp_fail - || T2.internal_pretty_code == pp_fail - || T3.internal_pretty_code == pp_fail - then pp_fail - else - fun par fmt (x1, x2, x3) -> + if T1.internal_pretty_code == undefined + || T2.internal_pretty_code == undefined + || T3.internal_pretty_code == undefined + then undefined + else + if T1.internal_pretty_code == pp_fail + || T2.internal_pretty_code == pp_fail + || T3.internal_pretty_code == pp_fail + then pp_fail + else + fun par fmt (x1, x2, x3) -> let pp fmt = Format.fprintf fmt @@ -1364,8 +1417,127 @@ Type.par par Type.Tuple fmt pp end) -module Triple_with_collections(T1: S)(T2: S)(T3: S)(Info:Functor_info) = - Generic_make_with_collections(Triple(T1)(T2)(T3))(Info) +module Quadruple(T1: S)(T2: S)(T3: S)(T4:S) = + Make + (struct + type t = T1.t * T2.t * T3.t * T4.t + let name = + Printf.sprintf "(%s, %s, %s, %s)" + T1.name T2.name T3.name T4.name + let reprs = + Caml_list.fold_left + (fun acc x1 -> + Caml_list.fold_left + (fun acc x2 -> + Caml_list.fold_left + (fun acc x3 -> + Caml_list.fold_left + (fun acc x4 -> + (x1, x2, x3, x4) :: acc) + acc + T4.reprs) + acc + T3.reprs) + acc + T2.reprs) + [] + T1.reprs + let structural_descr = + Structural_descr.t_tuple + [| T1.packed_descr; T2.packed_descr; T3.packed_descr; + T4.packed_descr |] + let equal = + if T1.equal == undefined + || T2.equal == undefined + || T3.equal == undefined + || T4.equal == undefined + then undefined + else + fun (x1, x2, x3, x4) (y1, y2, y3, y4) -> + T1.equal x1 y1 && T2.equal x2 y2 && T3.equal x3 y3 && T4.equal x4 y4 + let compare = + if T1.compare == undefined + || T2.compare == undefined + || T3.compare == undefined + || T4.compare == undefined + then undefined + else + fun (x1, x2, x3, x4 as x) (y1, y2, y3, y4 as y) -> + if x == y then 0 + else + let n = T1.compare x1 y1 in + if n = 0 then + let n = T2.compare x2 y2 in + if n = 0 then + let n = T3.compare x3 y3 in + if n = 0 then T4.compare x4 y4 + else n + else n + else n + let hash = + if T1.hash == undefined + || T2.hash == undefined + || T3.hash == undefined + || T4.hash == undefined + then undefined + else + fun (x1, x2, x3, x4) -> + Initial_caml_hashtbl.hash + (T1.hash x1, T2.hash x2, T3.hash x3, T4.hash x4) + let copy = + if T1.copy == undefined + || T2.copy == undefined + || T3.copy == undefined + || T4.copy == undefined + then undefined + else fun (x1, x2, x3,x4) -> + T1.copy x1, T2.copy x2, T3.copy x3, T4.copy x4 + let rehash = identity + let varname = undefined + let mem_project = + if T1.mem_project == undefined + || T2.mem_project == undefined + || T3.mem_project == undefined + || T4.mem_project == undefined + then undefined + else + if T1.mem_project == never_any_project + && T2.mem_project == never_any_project + && T3.mem_project == never_any_project + && T4.mem_project == never_any_project + then never_any_project + else + fun f (x1, x2, x3, x4) -> + T1.mem_project f x1 + && T2.mem_project f x2 + && T3.mem_project f x3 + && T4.mem_project f x4 + let pretty = from_pretty_code + let internal_pretty_code = + if T1.internal_pretty_code == undefined + || T2.internal_pretty_code == undefined + || T3.internal_pretty_code == undefined + || T4.internal_pretty_code == undefined + then undefined + else + if T1.internal_pretty_code == pp_fail + || T2.internal_pretty_code == pp_fail + || T3.internal_pretty_code == pp_fail + || T4.internal_pretty_code == pp_fail + then pp_fail + else + fun par fmt (x1, x2, x3, x4) -> + let pp fmt = + Format.fprintf + fmt + "%a, %a, %a, %a" + (T1.internal_pretty_code Type.Tuple) x1 + (T2.internal_pretty_code Type.Tuple) x2 + (T3.internal_pretty_code Type.Tuple) x3 + (T4.internal_pretty_code Type.Tuple) x4 + in + Type.par par Type.Tuple fmt pp + end) module Pair_with_collections(T1: S)(T2: S)(Info:Functor_info) = Generic_make_with_collections @@ -1375,6 +1547,15 @@ end) (Info) +module Triple_with_collections(T1: S)(T2: S)(T3: S)(Info:Functor_info) = + Generic_make_with_collections(Triple(T1)(T2)(T3))(Info) + +module Quadruple_with_collections(T1:S)(T2:S)(T3:S)(T4:S)(Info:Functor_info) = + Generic_make_with_collections(Quadruple(T1)(T2)(T3)(T4))(Info) + +module Option_with_collections(T:S)(Info:Functor_info) = + Generic_make_with_collections (Option(T))(Info) + (* Local Variables: compile-command: "make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/type/datatype.mli frama-c-20111001+nitrogen+dfsg/src/type/datatype.mli --- frama-c-20110201+carbon+dfsg/src/type/datatype.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/type/datatype.mli 2011-10-10 08:38:09.000000000 +0000 @@ -189,8 +189,8 @@ val rehash: t -> t (** How to rehashconsed values. Must be {!identity} if you does not use - hashconsing. Only useful for unmarshaling (use {!undefined for - unmarshable type}). ) + hashconsing. Only useful for unmarshaling (use {!undefined} for + unmarshable type). ) (** All the above operations have the same semantics than the corresponding value specified in module type {!S}. *) @@ -238,7 +238,7 @@ (** A standard OCaml map signature extended with datatype operations. *) module type Map = sig - include Map.S + include Map_common_interface.S module Key: S with type t = key (** Datatype for the keys of the map. *) @@ -254,6 +254,12 @@ include Hashtbl.S + val memo: 'a t -> key -> (key -> 'a) -> 'a + (** [memo tbl k f] returns the binding of [k] in [tbl]. If there is + no binding, add the binding [f k] associated to [k] in [tbl] and return + it. + @since Nitrogen-20111001 *) + module Key: S with type t = key (** Datatype for the keys of the hashtbl. ) @@ -311,7 +317,7 @@ module Formatter: S with type t = Format.formatter val formatter: Format.formatter Type.t -module Big_int: S_with_collections with type t = Big_int.big_int +module Big_int: S_with_collections with type t = My_bigint.t val big_int: Big_int.t Type.t ( **************************************************************************) @@ -393,6 +399,11 @@ module Poly_option: Polymorphic with type 'a poly = 'a option module Option(T: S) : S with type t = T.t option + +( @since Nitrogen-20111001 ) +module Option_with_collections(T:S)(Info: Functor_info): + S_with_collections with type t = T.t option + val option: 'a Type.t -> 'a option Type.t module Poly_list: Polymorphic with type 'a poly = 'a list @@ -407,6 +418,14 @@ module Triple_with_collections(T1: S)(T2: S)(T3: S)(Info: Functor_info): S_with_collections with type t = T1.t T2.t * T3.t +(** @since Nitrogen-20111001 ) +module Quadruple(T1: S)(T2: S)(T3: S)(T4:S): + S with type t = T1.t T2.t * T3.t * T4.t +(** @since Nitrogen-20111001 ) +module Quadruple_with_collections + (T1: S)(T2: S)(T3: S)(T4:S)(Info: Functor_info): + S_with_collections with type t = T1.t T2.t * T3.t * T4.t + module Function (T1: sig include S val label: (string * (unit -> t) option) option end) (T2: S) @@ -446,7 +465,7 @@ module Set(S: Set.S)(E: S with type t = S.elt)(Info : Functor_info): Set with type t = S.t and type elt = E.t -module Map(M: Map.S)(Key: S with type t = M.key)(Info: Functor_info) : +module Map(M: Map_common_interface.S)(Key: S with type t = M.key)(Info: Functor_info) : Map with type 'a t = 'a M.t and type key = M.key and module Key = Key module Hashtbl(H: Hashtbl.S)(Key: S with type t = H.key)(Info : Functor_info): diff -Nru frama-c-20110201+carbon+dfsg/src/type/descr.ml frama-c-20111001+nitrogen+dfsg/src/type/descr.ml --- frama-c-20110201+carbon+dfsg/src/type/descr.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/type/descr.ml 2011-10-10 08:38:09.000000000 +0000 @@ -30,6 +30,8 @@ let coerce d = (d : single_pack :> Unmarshal.t) +let uncheck_pack d = try unsafe_pack d with Cannot_pack -> assert false + (* ********************************************************************** *) (** {2 Predefined type descriptors} ) ( ********************************************************************** ) @@ -37,14 +39,14 @@ let unmarshable = pack Unknown let is_unmarshable x = x = unmarshable -let t_unit = unsafe_pack Unmarshal.t_unit -let t_int = unsafe_pack Unmarshal.t_int -let t_string = unsafe_pack Unmarshal.t_string -let t_float = unsafe_pack Unmarshal.t_float -let t_bool = unsafe_pack Unmarshal.t_bool -let t_int32 = unsafe_pack Unmarshal.t_int32 -let t_int64 = unsafe_pack Unmarshal.t_int64 -let t_nativeint = unsafe_pack Unmarshal.t_nativeint +let t_unit = uncheck_pack Unmarshal.t_unit +let t_int = uncheck_pack Unmarshal.t_int +let t_string = uncheck_pack Unmarshal.t_string +let t_float = uncheck_pack Unmarshal.t_float +let t_bool = uncheck_pack Unmarshal.t_bool +let t_int32 = uncheck_pack Unmarshal.t_int32 +let t_int64 = uncheck_pack Unmarshal.t_int64 +let t_nativeint = uncheck_pack Unmarshal.t_nativeint ( ********************************************************************** *) (** {2 Type descriptor builders} ) @@ -58,10 +60,10 @@ try let x = Array.map - (fun x -> match x with - | Nopack | Recursive _ -> raise Invalid_descriptor - | Pack x -> coerce x) - x + (fun x -> match x with + | Nopack | Recursive _ -> raise Invalid_descriptor + | Pack x -> coerce x) + x in unsafe_pack (Unmarshal.t_record x) with Cannot_pack -> @@ -70,12 +72,12 @@ let t_tuple = t_record let t_pair x y = match x, y with | (Nopack | Recursive _), _ | _, (Nopack | Recursive _) -> unmarshable - | Pack x, Pack y -> unsafe_pack (Unmarshal.t_tuple [| coerce x; coerce y |]) + | Pack x, Pack y -> uncheck_pack (Unmarshal.t_tuple [| coerce x; coerce y |]) let t_poly f = function | Nopack -> unmarshable | Recursive _ -> raise Invalid_descriptor - | Pack x -> unsafe_pack (f (coerce x)) + | Pack x -> uncheck_pack (f (coerce x)) let t_list = t_poly Unmarshal.t_list let t_ref = t_poly Unmarshal.t_ref @@ -86,7 +88,9 @@ let of_type ty = pack (Type.structural_descr ty) let of_structural ty d = - if Structural_descr.are_consistent (Type.structural_descr ty) d then + if not (Type.may_use_obj ()) || + Structural_descr.are_consistent (Type.structural_descr ty) d + then pack d else invalid_arg "Descr.of_structural: inconsistent descriptor" @@ -101,20 +105,20 @@ | Nopack | Recursive _ -> raise Invalid_descriptor | Pack b -> coerce b in - unsafe_pack (Unmarshal.Structure (Unmarshal.Dependent_pair (coerce a, f))) + uncheck_pack (Unmarshal.Structure (Unmarshal.Dependent_pair (coerce a, f))) let return d f = match d with | Nopack -> unmarshable | Recursive _ -> raise Invalid_descriptor | Pack d -> - unsafe_pack (Unmarshal.Return(coerce d, (fun x -> Obj.repr (f x)))) + uncheck_pack (Unmarshal.Return(coerce d, (fun x -> Obj.repr (f x)))) let dynamic f = let f () = match f () with | Nopack | Recursive _ -> raise Invalid_descriptor | Pack y -> coerce y in - unsafe_pack (Unmarshal.Dynamic f) + uncheck_pack (Unmarshal.Dynamic f) module Unmarshal_tbl = Hashtbl.Make @@ -131,10 +135,10 @@ let l = ref [] in Array.iter (fun a -> - Array.iteri - (fun i y -> - if x == y then l := (a, i) :: !l else transform_unmarshal term x y) - a) + Array.iteri + (fun i y -> + if x == y then l := (a, i) :: !l else transform_unmarshal term x y) + a) arr; List.iter (fun (a, i) -> a.(i) <- term) !l | Unmarshal.Dependent_pair(d, _) | Unmarshal.Array d -> @@ -162,7 +166,7 @@ let term = Unmarshal.Transform(d, fun x -> Obj.repr (f (Obj.obj x))) in transform_unmarshal term d d; Unmarshal_tbl.clear visited; - unsafe_pack term + uncheck_pack term ( ********************************************************************** *) (** {2 Coercions} *) diff -Nru frama-c-20110201+carbon+dfsg/src/type/structural_descr.ml frama-c-20111001+nitrogen+dfsg/src/type/structural_descr.ml --- frama-c-20110201+carbon+dfsg/src/type/structural_descr.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/type/structural_descr.ml 2011-10-10 08:38:09.000000000 +0000 @@ -35,14 +35,6 @@ (** {2 Injection into Unmarshal} ) ( ********************************************************************** ) -module Unmarshal_tbl = - Hashtbl.Make - (struct - type t = Unmarshal.t - let equal = (==) - let hash = Hashtbl.hash - end) - module Recursive = struct let create () = ref Unknown @@ -53,9 +45,9 @@ module Tbl = Hashtbl.Make (struct - type t = recursive - let equal = (==) - let hash = Hashtbl.hash + type t = recursive + let equal = (==) + let hash = Hashtbl.hash end) let positions = Tbl.create 7 @@ -115,6 +107,8 @@ | Unmarshal.Transform _ | Unmarshal.Return _ | Unmarshal.Dynamic _ -> assert false ( not structural ) +let recursive_pack r = Recursive r + ( ********************************************************************** *) (** {2 Predefined values} ) ( ********************************************************************** ) @@ -173,6 +167,14 @@ ( {3 cleanup} ) ( ********************************************************************** ) +module Unmarshal_tbl = + Hashtbl.Make + (struct + type t = Unmarshal.t + let equal = (==) + let hash = Hashtbl.hash + end) + let unmarshal_visited = Unmarshal_tbl.create 7 module Tbl = @@ -246,11 +248,11 @@ | Unmarshal.Sum arr1, Unmarshal.Sum arr2 -> (try for i = 0 to Array.length arr1 - 1 do - let arr1_i = arr1.(i) in - for j = 0 to Array.length arr1_i - 1 do - if not (are_consistent_unmarshal arr1_i.(j) arr2.(i).(j)) then - raise Exit - done + let arr1_i = arr1.(i) in + for j = 0 to Array.length arr1_i - 1 do + if not (are_consistent_unmarshal arr1_i.(j) arr2.(i).(j)) then + raise Exit + done done; true with Invalid_argument _ | Exit -> @@ -294,10 +296,10 @@ | Sum arr1, Sum arr2 -> (try for i = 0 to Array.length arr1 - 1 do - let arr1_i = arr1.(i) in - for j = 0 to Array.length arr1_i - 1 do - if not (are_consistent_pack arr1_i.(j) arr2.(i).(j)) then raise Exit - done + let arr1_i = arr1.(i) in + for j = 0 to Array.length arr1_i - 1 do + if not (are_consistent_pack arr1_i.(j) arr2.(i).(j)) then raise Exit + done done; true with Invalid_argument _ | Exit -> @@ -319,7 +321,7 @@ let are_consistent d1 d2 = assert (Unmarshal_tbl.length unmarshal_consistent_visited = 0 - && Tbl.length consistent_visited = 0); + && Tbl.length consistent_visited = 0); let b = are_consistent_aux d1 d2 in Unmarshal_tbl.clear unmarshal_consistent_visited; Tbl.clear consistent_visited; diff -Nru frama-c-20110201+carbon+dfsg/src/type/structural_descr.mli frama-c-20111001+nitrogen+dfsg/src/type/structural_descr.mli --- frama-c-20110201+carbon+dfsg/src/type/structural_descr.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/type/structural_descr.mli 2011-10-10 08:38:09.000000000 +0000 @@ -38,12 +38,14 @@ It MUST NOT be used directly in any case. ) -(** Structural descriptor used inside structural descriptor. *) -type pack = - | Nopack (** Internal use only *) - | Pack of single_pack (** Internal use only *) - | Recursive of recursive (** Use for handling recursive structural - descriptor. See module {!Recursive}. *) +(** Structural descriptor used inside structures. + @modify Nitrogen-20111001 this type is now private. Use smart + constructors instead. *) +type pack = private + | Nopack (** Was impossible to build a pack. *) + | Pack of single_pack (** A standard pack. *) + | Recursive of recursive (** Pack for a recursive descriptor. + See module {!Recursive}. *) (** Type of internal representations of OCaml type. @@ -51,7 +53,7 @@ is [Structure (Sum [| [| p_int; p_bool |]; [| p_string |] |])]. Ok, in this case, just [Abstract] is valid too. *) type t = - | Unknown + | Unknown (** Use it either for unmarshable types or if you don't know its internal representation. In any case, values of types with such a descriptor will be never write on disk. *) @@ -63,7 +65,8 @@ | Structure of structure (** Provide a description of the representation of data. *) - | T_pack of single_pack (** Internal use only *) + | T_pack of single_pack (** Internal use only. + Do not use it outside the library *) (** Description with details. ) and structure = @@ -75,14 +78,18 @@ corresponding constructor. ) | Array of pack (** The data is an array of values of the same type, each - value being described by the pack. ) + value being described by the pack. ) (* ********************************************************************** *) -(** {2 Useful functions} *) +(** {2 Pack builders} ) ( ********************************************************************** *) val pack: t -> pack -(** Pack a structural descriptor for embedding inside another one. *) +(** Pack a structural descriptor in order to embed it inside another one. *) + +val recursive_pack: recursive -> pack +(** Pack a recursive descriptor. + @since Nitrogen-20111001 *) (** Use this module for handling a (possibly recursive) structural descriptor [d]. Call [Recursive.create ()] (returning [r]) before building [d]. Build diff -Nru frama-c-20110201+carbon+dfsg/src/type/type.ml frama-c-20111001+nitrogen+dfsg/src/type/type.ml --- frama-c-20110201+carbon+dfsg/src/type/type.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/type/type.ml 2011-10-10 08:38:09.000000000 +0000 @@ -33,6 +33,7 @@ let use_obj = ref true let no_obj () = use_obj := false +let may_use_obj () = !use_obj (* ****************************************************************************) (* ****************************************************************************) @@ -64,7 +65,6 @@ { name: string; digest: Digest.t; structural_descr: Structural_descr.t; - mutable is_dynamic_abstract:bool; mutable pp_ml_name: precedence -> Format.formatter -> unit } (* phantom type ) @@ -74,15 +74,12 @@ ( non-phantom type: the type variable is used here ) type 'a full_t = { ty: 'a t; reprs: 'a list } -type abstract - let types : (string ( name ), Obj.t full_t) Hashtbl.t = Hashtbl.create 97 let dummy = { name = ""; digest = ""; structural_descr = Structural_descr.Unknown; - is_dynamic_abstract = false; pp_ml_name = fun _ _ -> assert false } let mk_dyn_pp name = function @@ -92,17 +89,15 @@ | Some s -> let prec = try - ignore (Str.search_forward (Str.regexp " ") name 0); - Call + ignore (Str.search_forward (Str.regexp " ") name 0); + Call with Not_found -> - Basic + Basic in fun p fmt -> par p prec fmt (fun fmt -> Format.fprintf fmt "%s" s) exception AlreadyExists of string -let register - ?(closure=false) ?(dynamic_abstract=false) - ~name ~ml_name structural_descr reprs = +let register ?(closure=false) ~name ~ml_name structural_descr reprs = let error () = invalid_arg ("Type.register: invalid reprs for type " ^ name) in @@ -118,24 +113,28 @@ let pp_ml_name = mk_dyn_pp name ml_name in let digest = match structural_descr with | Structural_descr.Unknown -> - ( unserializable type: weakest digest ) - Digest.string name + ( unserializable type: weakest digest ) + Digest.string name | _ -> - let key = name, Structural_descr.cleanup structural_descr, reprs in - Digest.string (Marshal.to_string key []) + let key = name, Structural_descr.cleanup structural_descr, reprs in + Digest.string (Marshal.to_string key []) in let ty = - { name = name; digest = digest; structural_descr = structural_descr; - is_dynamic_abstract = dynamic_abstract; pp_ml_name = pp_ml_name } + { name = name; + digest = digest; + structural_descr = structural_descr; + pp_ml_name = pp_ml_name } in let full_ty = { ty = ty; reprs = List.map Obj.repr reprs } in if !use_obj then Hashtbl.add types name full_ty; ty -exception Not_dynamic of string -let get x = - if !use_obj then (Hashtbl.find types x).ty - else failwith "Cannot call `Type.get' in `no obj' mode" +module Abstract(T: sig val name: string end) = struct + type t + let ty = + if !use_obj then (Hashtbl.find types T.name).ty + else failwith "Cannot call `Type.get' in `no obj' mode" +end let name ty = ty.name let structural_descr ty = ty.structural_descr @@ -148,15 +147,14 @@ let unsafe_reprs ty = (Hashtbl.find types ty.name).reprs let reprs ty = - let l = try unsafe_reprs ty with Not_found -> assert false in + let l = try unsafe_reprs ty with Not_found -> Format.printf "Type %s@." + ty.name ;assert false in List.map Obj.obj l let set_ml_name ty ml_name = let pp = mk_dyn_pp ty.name ml_name in ty.pp_ml_name <- pp -let is_dynamic_abstract ty = ty.is_dynamic_abstract <- true - ( **************************************************************************) ( {2 Type values are comparable} ) ( ****************************************************************************) @@ -216,18 +214,18 @@ let instantiate (ty:'a t) = if !use_obj then try - Tbl.find ty, false + Tbl.find ty, false with Not_found -> - let repr = - register - ~name:(T.name ty) - ~ml_name:(Some (ml_name ty)) - (T.structural_descr ty.structural_descr) - (List.fold_left - (fun acc ty -> T.reprs ty @ acc) [] (unsafe_reprs ty)) - in - Tbl.add ty repr; - repr, true + let repr = + register + ~name:(T.name ty) + ~ml_name:(Some (ml_name ty)) + (T.structural_descr ty.structural_descr) + (List.fold_left + (fun acc ty -> T.reprs ty @ acc) [] (unsafe_reprs ty)) + in + Tbl.add ty repr; + repr, true else dummy, false @@ -276,37 +274,37 @@ let ml_name from_ty1 from_ty2 = let b = Buffer.create 31 in Format.bprintf b "%s.instantiate %t %t" - T.module_name - (from_ty1.pp_ml_name Call) - (from_ty2.pp_ml_name Call); + T.module_name + (from_ty1.pp_ml_name Call) + (from_ty2.pp_ml_name Call); Buffer.contents b let instantiate a b = if !use_obj then let key = a, b in try - Concrete_pair.find memo_tbl key, false + Concrete_pair.find memo_tbl key, false with Not_found -> - let reprs = - List.fold_left - (fun acc r1 -> - List.fold_left - (fun acc r2 -> T.reprs r1 r2 @ acc) - acc - (unsafe_reprs b)) - [] - (unsafe_reprs a) - in - let ty = - register - ~name:(T.name a b) - ~ml_name:(Some (ml_name a b)) - (T.structural_descr a.structural_descr b.structural_descr) - reprs - in - Concrete_pair.add memo_tbl key ty; - Tbl.add instances ty key; - ty, true + let reprs = + List.fold_left + (fun acc r1 -> + List.fold_left + (fun acc r2 -> T.reprs r1 r2 @ acc) + acc + (unsafe_reprs b)) + [] + (unsafe_reprs a) + in + let ty = + register + ~name:(T.name a b) + ~ml_name:(Some (ml_name a b)) + (T.structural_descr a.structural_descr b.structural_descr) + reprs + in + Concrete_pair.add memo_tbl key ty; + Tbl.add instances ty key; + ty, true else dummy, false @@ -339,11 +337,11 @@ module Memo = Hashtbl.Make (struct - type t = instance - let hash x = - Hashtbl.hash (hash x.arg, hash x.ret, Hashtbl.hash x.label) - let equal x y = - equal x.arg y.arg && equal x.ret y.ret && x.label = y.label + type t = instance + let hash x = + Hashtbl.hash (hash x.arg, hash x.ret, x.label) + let equal x y = + equal x.arg y.arg && equal x.ret y.ret && x.label = y.label end) let memo_tbl : concrete_repr Memo.t = Memo.create 17 let instances @@ -366,12 +364,12 @@ let get_optional_argument (ty:('a, 'b) poly t) = if !use_obj then try - match Tbl.find instances ty with - | _, None -> None - | _, Some o -> Some (Obj.obj o : unit -> 'b) + match Tbl.find instances ty with + | _, None -> None + | _, Some o -> Some (Obj.obj o : unit -> 'b) with Not_found -> - (* static typing ensures than [ty] has already been instantiated. ) - assert false + ( static typing ensures than [ty] has already been instantiated. ) + assert false else invalid_arg "cannot call `Type.get_optional_argument in the 'no obj' mode" @@ -391,29 +389,29 @@ let instantiate ?label (a:'a) (b:'b t) = if !use_obj then let l, o = match label with - | None -> None, None - | Some (l, None) -> Some l, None - | Some (l, Some o) -> Some l , Some (Obj.repr o) + | None -> None, None + | Some (l, None) -> Some l, None + | Some (l, Some o) -> Some l , Some (Obj.repr o) in let key = { arg = a; ret = b; label = l } in try - Memo.find memo_tbl key, false + Memo.find memo_tbl key, false with Not_found -> - let ty = - ( Do not inline [Types.repr b] in the closure below because - caml is not able to marshal the closure. - Sadly don't know exactly why. Seem to have some value tagged as - abstract in the closure environment. ) - register - ~closure:true - ~name:(name l a b) - ~ml_name:(Some (ml_name l a b)) - Structural_descr.Unknown - (List.map (fun r _ -> r) (unsafe_reprs b)) - in - Memo.add memo_tbl key ty; - Tbl.add instances ty (key, o); - ty, true + let ty = + ( Do not inline [Types.repr b] in the closure below because + caml is not able to marshal the closure. + Sadly don't know exactly why. Seem to have some value tagged as + abstract in the closure environment. ) + register + ~closure:true + ~name:(name l a b) + ~ml_name:(Some (ml_name l a b)) + Structural_descr.Unknown + (List.map (fun r _ -> r) (unsafe_reprs b)) + in + Memo.add memo_tbl key ty; + Tbl.add instances ty (key, o); + ty, true else dummy, false @@ -438,7 +436,7 @@ module Ty_tbl(Info: sig type 'a t end) = struct type t = Obj.t Tbl.t - let create = Tbl.create + let create x = Tbl.create x let add tbl (ty:'a ty) (x:'a Info.t) = Tbl.add tbl ty (Obj.repr x) let find tbl (ty:'a ty) = (Obj.obj (Tbl.find tbl ty) : 'a Info.t) end @@ -457,19 +455,19 @@ type t = Obj.t let equal = (==) let hash x = - if !use_obj then - ( 0 is correct; trying to do a bit better... ) - let tag = Obj.tag x in - if tag = 0 then - 0 - else if tag = Obj.closure_tag then - ( assumes that the first word of a closure does not change in - anyway (even by Gc.compact invokation). ) - Obj.magic (Obj.field x 0) - else - Hashtbl.hash x - else - 0 + if !use_obj then + ( 0 is correct; trying to do a bit better... ) + let tag = Obj.tag x in + if tag = 0 then + 0 + else if tag = Obj.closure_tag then + ( assumes that the first word of a closure does not change in + any way (even by Gc.compact invokation). ) + Obj.magic (Obj.field x 0) + else + Hashtbl.hash x + else + 0 end) type 'a t = 'a O.t Tbl.t @@ -479,11 +477,11 @@ let add tbl ty k v = if !use_obj then let tytbl = - try Tbl.find tbl ty - with Not_found -> - let tytbl = O.create 7 in - Tbl.add tbl ty tytbl; - tytbl + try Tbl.find tbl ty + with Not_found -> + let tytbl = O.create 7 in + Tbl.add tbl ty tytbl; + tytbl in O.replace tytbl (Obj.repr k) v @@ -513,7 +511,7 @@ module O = Weak.Make(struct ( we use the weak hash tbl as a weak list since we cannot use [(==)] in - weak hash tables. See documentation of module Weak. ) + weak hash tables. See documentation of module Weak. ) type t = Obj.t let equal _ _ = false let hash _ = 0 @@ -526,11 +524,11 @@ let add tbl ty k = if !use_obj then let tytbl = - try Tbl.find tbl ty - with Not_found -> - let tytbl = O.create 7 in - Tbl.add tbl ty tytbl; - tytbl + try Tbl.find tbl ty + with Not_found -> + let tytbl = O.create 7 in + Tbl.add tbl ty tytbl; + tytbl in O.add tytbl (Obj.repr k) @@ -540,10 +538,10 @@ let objs = Tbl.find tbl ty in assert !use_obj; try - O.iter (fun x -> if x == Obj.repr k then raise Exit) objs; - false + O.iter (fun x -> if x == Obj.repr k then raise Exit) objs; + false with Exit -> - true + true with Not_found -> false @@ -554,7 +552,7 @@ type 'a info type t val create: int -> t - val add: t -> key -> 'a ty -> 'a info -> 'a info + val add: t -> key -> 'a ty -> 'a info -> unit exception Unbound_value of string exception Incompatible_type of string val find: t -> key -> 'a ty -> 'a info @@ -573,61 +571,31 @@ exception Incompatible_type of string - let create = H.create - let values_of_abstracts = Obj_weak.create () - - let rec objectify name n ty x : Obj.t = - assert !use_obj; - if ty.is_dynamic_abstract then Obj_weak.add values_of_abstracts ty x; - if Function.is_instance_of ty then - let a, b, _ = Function.get_instance ty in - (* ok: [x] is a function here ) - let f : 'a -> 'b = Obj.magic x in - Obj.repr - (fun (y:'a) -> - ( for dynamic types, dynamically check that the argument was - built with a constructor of this type. ) - if a.is_dynamic_abstract && not (Obj_weak.mem values_of_abstracts a y) - then begin - let msg = - Format.sprintf - "argument %d of %s not built with a constructor of type %s" - n name a.name - in - raise (Incompatible_type msg) - end; - ( recursive call *) - (Obj.obj (objectify name (succ n) b (f y)) : 'b)) - else - Obj.repr x + let create x = H.create x let add tbl s ty x = if !use_obj then begin let name = Key.to_string s in if H.mem tbl s then raise (AlreadyExists name); - let o = objectify name 1 ty x in - H.add tbl s { ty = ty; o = o }; - Obj.obj o - end else - x + H.add tbl s { ty = ty; o = Obj.repr x } + end exception Unbound_value of string let type_error s ty_name ty_name' = raise (Incompatible_type - (Format.sprintf "%s has type %s but is used with type %s." - s ty_name' ty_name)) + (Format.sprintf "%s has type %s but is used with type %s." + s ty_name' ty_name)) let find tbl s ty = if !use_obj then let name = Key.to_string s in - try - let data = H.find tbl s in - if ty.digest <> data.ty.digest then - type_error name ty.name data.ty.name; - Obj.obj data.o - with Not_found -> - raise (Unbound_value name) + let data = + try H.find tbl s with Not_found -> raise (Unbound_value name) + in + if ty.digest <> data.ty.digest then + type_error name ty.name data.ty.name; + Obj.obj data.o else invalid_arg "cannot call function 'find' in the 'no obj' mode" @@ -637,7 +605,7 @@ Make_tbl (struct type t = string - let hash = Hashtbl.hash + let hash x = Hashtbl.hash x let equal : string -> string -> bool = (=) let to_string x = x end) diff -Nru frama-c-20110201+carbon+dfsg/src/type/type.mli frama-c-20111001+nitrogen+dfsg/src/type/type.mli --- frama-c-20110201+carbon+dfsg/src/type/type.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/type/type.mli 2011-10-10 08:38:09.000000000 +0000 @@ -30,6 +30,11 @@ (** Deactivate all the black magic. Roughly, in this mode, nothing is done by this module. *) +(/) +val may_use_obj: unit -> bool +(** Internal use only. Please, do not use it yourself. ) +(/) + ( **************************************************************************) ( {2 Type declaration} ) ( ************************************************************************) @@ -83,13 +88,12 @@ val register: ?closure:bool -> - ?dynamic_abstract:bool -> name:string -> ml_name:string option -> Structural_descr.t -> 'a list -> 'a t -( [register ?closure ?dynamic_abstract ~name ~ml_name descr reprs] registers +( [register ?closure ~name ~ml_name descr reprs] registers a new type value. Should not be used directly. Use one of functors of module {!Datatype} instead. @raise AlreadyExists if the given name is already used by another type. @@ -99,23 +103,24 @@ @modify Carbon-20101201 [value_name] is now [ml_name]. Must provide a structural descriptor. Argument [pp] does not exist anymore. *) -type abstract -val get: string -> abstract t -(** @return the type value from its name. *) +(** Apply this functor to access to the abstract type of the given name. + @since Nitrogen-20111001 *) +module Abstract(T: sig val name: string end): sig + type t + val ty: t ty +end val name: 'a t -> string val structural_descr: 'a t -> Structural_descr.t val reprs: 'a t -> 'a list +(** Not usable in the "no-obj" mode *) + val digest: 'a t -> Digest.t val ml_name: 'a t -> string val pp_ml_name: 'a t -> precedence -> Format.formatter -> unit val set_ml_name: 'a t -> string option -> unit -val is_dynamic_abstract: 'a t -> unit -(** Call this function to indicate that this type is an abstract type - dynamically registered. ) - ( **************************************************************************) ( {2 Type values are comparable} ) ( **************************************************************************) @@ -146,7 +151,7 @@ type 'a t ( Static polymorphic type corresponding to its dynamic counterpart to - register. ) + register. ) val reprs: 'a -> 'a t list (** How to make the representant of each monomorphic instance of the @@ -164,18 +169,18 @@ val instantiate: 'a t -> 'a poly t * bool (** @return the monomorphic instantiation of the polymorph type with the - given type value. For instance, if ['a poly = 'a list], then - [instantiate int] returns the type value [int list]. ) + given type value. For instance, if ['a poly = 'a list], then + [instantiate int] returns the type value [int list]. ) val is_instance_of: 'a t -> bool (** @return [true] iff the given type value has been created from - function [instantiate] above. - For instance, [is_instance_of (instantiate int)] always returns [true] - but [is_instance_of int] always returns [false]. ) + function [instantiate] above. + For instance, [is_instance_of (instantiate int)] always returns [true] + but [is_instance_of int] always returns [false]. ) val get_instance: 'a poly t -> 'a t (** [get_instance ty] returns the type value used to create the given - monomorphic instantiation. ) + monomorphic instantiation. ) end @@ -214,7 +219,7 @@ val instantiate: ?label:string * (unit -> 'a) option -> 'a t -> 'b t -> ('a -> 'b) t * bool (** Possibility to add a label for the parameter. - - [~label:(p,None)] for a mandatory labelized parameter [p]; + - [~label:(p,None)] for a mandatory labelized parameter [p]; - [~label:(p,Some f)] for an optional labelized parameter [p], with default value [f ()]. *) val is_instance_of: 'a t -> bool @@ -237,19 +242,18 @@ type 'a info type t (** Type of heterogeneous (hash)tables indexed by values of type Key.t. - Type values ensure type safety. ) + Type values ensure type safety. ) val create: int -> t (** [create n] creates a new table of initial size [n]. *) - val add: t -> key -> 'a ty -> 'a info -> 'a info + val add: t -> key -> 'a ty -> 'a info -> unit (** [add tbl s ty v] binds [s] to the value [v] in the table [tbl]. - If the returned value is a closure whose the type of one of its - argument was dynamically registered, then it may raise - [Incompatible_Type]. - @return the exact value stored in the table which is observationally - equal to [v] but it deals better with dynamic types. - @raise AlreadyExists if [s] is already bound in [tbl]. ) + If the returned value is a closure whose the type of one of its + argument was dynamically registered, then it may raise + [Incompatible_Type]. + @raise AlreadyExists if [s] is already bound in [tbl]. + @modify Nitrogen-20111001 returns [unit] now. ) exception Unbound_value of string exception Incompatible_type of string @@ -257,9 +261,9 @@ val find: t -> key -> 'a ty -> 'a info (** [find tbl s ty] returns the binding of [s] in the table [tbl]. - @raise Unbound_value if [s] is not bound in [tbl]. - @raise Incompatible_Type if [ty] was not the type value used to add - the binding of [s] in [tbl]. ) + @raise Unbound_value if [s] is not bound in [tbl]. + @raise Incompatible_Type if [ty] was not the type value used to add + the binding of [s] in [tbl]. ) end diff -Nru frama-c-20110201+carbon+dfsg/src/users/users_register.ml frama-c-20111001+nitrogen+dfsg/src/users/users_register.ml --- frama-c-20110201+carbon+dfsg/src/users/users_register.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/users/users_register.ml 2011-10-10 08:38:23.000000000 +0000 @@ -57,11 +57,11 @@ | [] -> assert false | (current_function, _call_site) :: tail -> let treat_element (user, _call_site) = - ignore - (Users.memo - ~change:(Kernel_function.Hptset.add current_function) - (fun _ -> Kernel_function.Hptset.singleton current_function) - user) + ignore + (Users.memo + ~change:(Kernel_function.Hptset.add current_function) + (fun _ -> Kernel_function.Hptset.singleton current_function) + user) in List.iter treat_element tail @@ -71,41 +71,52 @@ let () = Cmdline.run_after_configuring_stage init let get kf = + let find kf = + try Users.find kf + with Not_found -> Kernel_function.Hptset.empty + in if Users.is_computed () then - Users.find kf + find kf else begin if Db.Value.is_computed () then begin feedback "requiring again the computation of the value analysis"; Project.clear - ~selection:(State_selection.Dynamic.with_dependencies Db.Value.self) - () + ~selection:(State_selection.Dynamic.with_dependencies Db.Value.self) + () end else feedback ~level:2 "requiring the computation of the value analysis"; add_value_hook (); !Db.Value.compute (); - Users.find kf + find kf end -let () = Db.Users.get := get +let () = + Db.register + (Db.Journalize("Users.get", + Datatype.func Kernel_function.ty Kernel_function.Hptset.ty)) + Db.Users.get + get -let main () = +let print () = if ForceUsers.get () then - begin - result "====== DISPLAYING USERS ======@\n%t\ - ====== END OF USERS ==========" - (fun fmt -> - !Db.Semantic_Callgraph.topologically_iter_on_functions - (fun kf -> - try - Format.fprintf fmt "@[%a: @[%a@]@]@\n" - Kernel_function.pretty_name kf - Kernel_function.Hptset.pretty (!Db.Users.get kf) - with Not_found -> - () (* [kf] is not called during analysis )) - ) ; - end + result "@[<v>====== DISPLAYING USERS ======@ %t\ + ====== END OF USERS ==========" + (fun fmt -> + !Db.Semantic_Callgraph.topologically_iter_on_functions + (fun kf -> + let callees = !Db.Users.get kf in + if not (Kernel_function.Hptset.is_empty callees) then + Format.fprintf fmt "@[<hov 4>%a: %a@]@ " + Kernel_function.pretty kf + (Pretty_utils.pp_iter + ~pre:"" ~sep:"@ " ~suf:"" Kernel_function.Hptset.iter + Kernel_function.pretty) + callees)) -let () = Db.Main.extend main +let print_once, _self_print = + State_builder.apply_once "Users_register.print" [ Users.self ] print + +let () = Db.Main.extend print_once ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/value/builtins.ml frama-c-20111001+nitrogen+dfsg/src/value/builtins.ml --- frama-c-20110201+carbon+dfsg/src/value/builtins.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/builtins.ml 2011-10-10 08:38:26.000000000 +0000 @@ -20,13 +20,14 @@ (* *) (**************************************************************************) -open Cvalue_type +open Cvalue open Abstract_interp open Cil open Locations open Value_util +open Cil_types -let table = Hashtbl.create 7 +let table = Hashtbl.create 17 let register_builtin name f = Hashtbl.add table name f @@ -39,6 +40,9 @@ let mem_builtin name = Hashtbl.mem table name let () = Db.Value.mem_builtin := mem_builtin +let overridden_by_builtin s = + try ignore (Value_parameters.BuiltinsOverrides.find s); true + with Not_found -> false let offsetmap_of_value ~typ v = V_Offsetmap.update_ival @@ -56,58 +60,136 @@ exception Found_misaligned_base -let frama_C_cos state actuals = +let double_double_fun name caml_fun state actuals = match actuals with [_, arg, _] -> begin - let r = - try - let i = Cvalue_type.V.project_ival arg in - let f = Ival.project_float i in - Cvalue_type.V.inject_ival - (Ival.inject_float (Ival.Float_abstract.cos_float f)) - with Cvalue_type.V.Not_based_on_null -> - Value_parameters.result ~once:true ~current:true - "Builtin Frama_C_cos applied to address"; - Cvalue_type.V.topify_arith_origin arg - in - (wrap_double r), state, Location_Bits.Top_Param.bottom + let r = + try + let i = Cvalue.V.project_ival arg in + let f = Ival.project_float i in + Cvalue.V.inject_ival + (Ival.inject_float (caml_fun f)) + with Cvalue.V.Not_based_on_null -> + Value_parameters.result ~once:true ~current:true "%s" + ("Builtin " ^ name ^ " applied to address"); + Cvalue.V.topify_arith_origin arg + in + (wrap_double r), state, Location_Bits.Top_Param.bottom end | _ -> - Value_parameters.error "Invalid argument for Frama_C_cos function"; + Value_parameters.error "%s" + ("Invalid argument for " ^ name ^ " function"); do_degenerate None; raise Db.Value.Aborted + +let frama_C_cos = double_double_fun "Frama_C_cos" Ival.Float_abstract.cos_float +let frama_C_cos_precise = + double_double_fun "Frama_C_cos_precise" Ival.Float_abstract.cos_float_precise + let () = register_builtin "Frama_C_cos" frama_C_cos +let () = register_builtin "Frama_C_cos_precise" frama_C_cos_precise + +let frama_C_sin = double_double_fun "Frama_C_sin" Ival.Float_abstract.sin_float +let () = register_builtin "Frama_C_sin" frama_C_sin + +let frama_C_sin_precise = + double_double_fun "Frama_C_sin_precise" Ival.Float_abstract.sin_float_precise +let () = register_builtin "Frama_C_sin_precise" frama_C_sin_precise + +let frama_C_exp = double_double_fun "Frama_C_exp" Ival.Float_abstract.exp_float +let () = register_builtin "Frama_C_exp" frama_C_exp + +(* +external cos_rd : float -> float = "caml_cos_rd" +external cos_ru : float -> float = "caml_cos_ru" +external crlibm_init : unit -> unit = "caml_crlibm_init" +) + +let frama_C_compare_cos state actuals = + match actuals with + [_, arg, _; _, res, _; _, eps, _] -> begin + try + let iarg = Cvalue.V.project_ival arg in + let farg = Ival.project_float iarg in + let larg,uarg = Ival.Float_abstract.min_and_max_float farg in + let larg = Ival.F.to_float larg in + let uarg = Ival.F.to_float uarg in + let ires = Cvalue.V.project_ival res in + let fres = Ival.project_float ires in + let lres,ures = Ival.Float_abstract.min_and_max_float fres in + let lres = Ival.F.to_float lres in + let ures = Ival.F.to_float ures in + let ieps = Cvalue.V.project_ival eps in + let feps = Ival.project_float ieps in + let _,ueps = Ival.Float_abstract.min_and_max_float feps in + let ueps = Ival.F.to_float ueps in +( crlibm_init(); + let lref = cos_rd uarg in (* cos is decreasing ) + let uref = cos_ru larg in ( cos is decreasing ) ) + Ival.set_round_nearest_even(); + (* system cos probably isn't designed for non-default rounding ) + let lref = cos uarg in + let uref = cos larg in + Ival.set_round_upward(); + let lallow = uref -. ueps in + Ival.set_round_downward(); + let uallow = lref +. ueps in + if lallow <= lres && ures <= uallow + then + Value_parameters.result "CC %1.16f %1.16f %1.16f %1.16f %1.16f %1.16f OK" + larg uarg + lres ures + lref uref + else + Value_parameters.result "CC %1.16f %1.16f %1.16f %1.16f %1.16f %1.16f KO" + larg uarg + lres ures + lref uref; + None, state, Location_Bits.Top_Param.bottom + with _ -> Value_parameters.error + "Invalid argument for Frama_C_compare_cos function"; + do_degenerate None; + raise Db.Value.Aborted + end + | _ -> Value_parameters.error + "Invalid argument for Frama_C_compare_cos function"; + do_degenerate None; + raise Db.Value.Aborted + +let () = register_builtin "Frama_C_compare_cos" frama_C_compare_cos + let frama_C_sqrt state actuals = match actuals with [_, arg, _] -> begin - let r = - try - let i = Cvalue_type.V.project_ival arg in - let f = Ival.project_float i in - let result_alarm, f = - Ival.Float_abstract.sqrt_float (get_rounding_mode()) f - in - if result_alarm - then -( CilE.warn_result_nan_infinite - (warn_all_quiet_mode ()) ; ) - Value_parameters.result ~once:true ~current:true - "float sqrt: assert (Ook)"; - Cvalue_type.V.inject_ival (Ival.inject_float f) - - with - Cvalue_type.V.Not_based_on_null -> - Value_parameters.result ~once:true ~current:true - "float sqrt applied to address"; - Cvalue_type.V.topify_arith_origin arg - | Ival.Float_abstract.Bottom -> - ignore (CilE.warn_once "sqrt: TODO -- a proper alarm"); - V.bottom - in - (wrap_double r), state, Location_Bits.Top_Param.bottom + let r = + try + let i = Cvalue.V.project_ival arg in + let f = Ival.project_float i in + let result_alarm, f = + Ival.Float_abstract.sqrt_float (get_rounding_mode()) f + in + if result_alarm + then +( CilE.warn_result_nan_infinite + (warn_all_quiet_mode ()) ; ) + Value_parameters.result ~once:true ~current:true + "float sqrt: assert (Ook)"; + Cvalue.V.inject_ival (Ival.inject_float f) + + with + Cvalue.V.Not_based_on_null -> + Value_parameters.result ~once:true ~current:true + "float sqrt applied to address"; + Cvalue.V.topify_arith_origin arg + | Ival.Float_abstract.Bottom -> + Value_parameters.warning ~once:true ~current:true + "sqrt: TODO -- a proper alarm"; + V.bottom + in + (wrap_double r), state, Location_Bits.Top_Param.bottom end | _ -> Value_parameters.error "Invalid argument for Frama_C_sqrt function"; @@ -116,74 +198,7 @@ let () = register_builtin "Frama_C_sqrt" frama_C_sqrt -exception Base_aligned_error - -let frama_C_is_base_aligned state actuals = - try begin - match actuals with - [_,x,_; _,y,_] -> - let i = Cvalue_type.V.project_ival y in - begin match i with - Ival.Set si -> - Location_Bytes.fold_i - (fun b _o () -> - Ival.O.iter - (fun int -> - if not (Base.is_aligned_by b int) - then raise Found_misaligned_base) - si) - x - (); - (wrap_int Cvalue_type.V.singleton_one), - state, - Location_Bits.Top_Param.bottom - | _ -> raise Found_misaligned_base - end - | _ -> raise Base_aligned_error - end - with Base_aligned_error -> - Cilmsg.error "Invalid arguments for Frama_C_is_base_aligned function" ; - do_degenerate None; - raise Db.Value.Aborted - | Found_misaligned_base - | Not_found ( from project_ival ) -> - (wrap_int Cvalue_type.V.zero_or_one), - state, - Location_Bits.Top_Param.bottom - -let () = register_builtin "Frama_C_is_base_aligned" frama_C_is_base_aligned - -exception Offset_error - -let frama_c_offset state actuals = - try begin - match actuals with - [_,x,_] -> - begin - let value = - try - let offsets = - Location_Bytes.fold_i - (fun _b o a -> Ival.join a o) - x - Ival.bottom - in - Cvalue_type.V.inject_ival offsets - with Location_Bytes.Error_Top -> - error - "Builtin Frama_C_offset is applied to a value not guaranteed to be an address"; - Cvalue_type.V.top_int - in - (wrap_int value), state, Location_Bits.Top_Param.bottom - end - | _ -> raise Offset_error - end - with Offset_error -> - Cilmsg.error "Invalid arguments for builtin Frama_C_offset" ; - do_degenerate None; - raise Db.Value.Aborted -let () = register_builtin "Frama_C_offset" frama_c_offset exception Invalid_CEA_alloc_infinite exception Not_found_lonely_key @@ -207,45 +222,48 @@ in let file_base,_file_offset = try - Cvalue_type.V.find_lonely_key file + Cvalue.V.find_lonely_key file with Not_found -> raise Not_found_lonely_key in let file = match file_base with - | Base.String (_,s) -> s + | Base.String (_,e) -> + ( match Base.get_string e with + Base.CSString s -> s + | Base.CSWstring _ -> assert false ) | Base.Var (s,_) | Base.Initialized_Var (s,_) -> s.Cil_types.vname - | Base.Null | Base.Cell_class _ -> raise Invalid_CEA_alloc_infinite + | Base.Null -> raise Invalid_CEA_alloc_infinite in let loc = Dynamic_Alloc_Table.memo - (fun file -> - let new_name = + (fun file -> + let new_name = if Extlib.string_prefix ~strict:true "Frama_C_alloc_" file - then file - else Format.sprintf "Frama_C_alloc_%s" file - in - let new_name = Cabs2cil.fresh_global new_name in - let unbounded_type = + then file + else Format.sprintf "Frama_C_alloc_%s" file + in + let new_name = Cabs2cil.fresh_global new_name in + let unbounded_type = Cil_types.TArray (intType, Some (new_exp ~loc:Cil_datatype.Location.unknown (Cil_types.Const (Cil_types.CStr "NOSIZE"))), empty_size_cache (),[]) - in - let new_varinfo = - makeGlobalVar ~logic:true new_name unbounded_type - in - let new_offsetmap = - Cvalue_type.V_Offsetmap.sized_zero (Bit_utils.memory_size ()) - in - let new_base = - Cvalue_type.Default_offsetmap.create_initialized_var - new_varinfo - Base.All - new_offsetmap - in - Location_Bytes.inject new_base Ival.zero) - file + in + let new_varinfo = + makeGlobalVar ~logic:true new_name unbounded_type + in + let new_offsetmap = + Cvalue.V_Offsetmap.sized_zero (Bit_utils.memory_size ()) + in + let new_base = + Cvalue.Default_offsetmap.create_initialized_var + new_varinfo + Base.All + new_offsetmap + in + Location_Bytes.inject new_base Ival.zero) + file in wrap_ptr loc, state, Location_Bits.Top_Param.bottom with @@ -259,94 +277,116 @@ let () = register_builtin "Frama_C_alloc_infinite" frama_c_alloc_infinite +let frama_c_dump_assert state _actuals = + Value_parameters.result ~current:true "Frama_C_dump_assert_each called:@\n(%a)@\nEnd of Frama_C_dump_assert_each output" + Cvalue.Model.pretty_c_assert state; + None, state, Location_Bits.Top_Param.bottom + +let () = register_builtin "Frama_C_dump_assert_each" frama_c_dump_assert + -let frama_c_memcpy state actuals = +( -------------------------------------------------------------------------- ) +( --- Builtins not registered in the table --- ) +( -------------------------------------------------------------------------- ) + +exception Invalid_CEA_alloc + +let alloc_with_validity initial_state actuals = try - match actuals with - | [exp_dst,dst,_; exp_src,src,_ ; exp_size,size,_] -> - let size = Cvalue_type.V.project_ival size in - let min,max = Ival.min_and_max size in - let min = match min with - | None -> Int.zero - | Some m -> Int.max m Int.zero - and max = match max with - | None -> assert false ( TODO ) - | Some m -> m - in - let size_min = Int.mul Int.eight min in - let right = loc_bytes_to_loc_bits src in - let left = loc_bytes_to_loc_bits dst in - let right_loc = make_loc right (Int_Base.inject size_min) in - let term_size = Logic_utils.expr_to_term ~cast:true exp_size in - let array_src = Logic_utils.array_with_range exp_src term_size - and array_dst = Logic_utils.array_with_range exp_dst term_size - in - CilE.set_syntactic_context (CilE.SyMemLogic array_src); - begin - match Relations_type.Model.copy_offsetmap - ~with_alarms:(warn_all_quiet_mode ()) - right_loc - state - with - | None -> - None, - Relations_type.Model.bottom, - Location_Bits.Top_Param.bottom - - | Some offsetmap -> - CilE.set_syntactic_context (CilE.SyMemLogic array_dst); - let new_state = - Relations_type.Model.paste_offsetmap - offsetmap left Int.zero size_min state - in - let fuzz = Int.sub max min in - if Int.is_zero fuzz - then None, new_state, Location_Bits.get_bases right - else - let fuzz = Int.mul Int.eight fuzz in - let fuzz = Int_Base.inject fuzz in - let ival_min = Ival.inject_singleton size_min in - let left = Location_Bits.location_shift ival_min left in - let right = Location_Bits.location_shift ival_min right in - CilE.set_syntactic_context (CilE.SyMemLogic array_src); - let garb = - Relations_type.Model.find - ~conflate_bottom:false - ~with_alarms:(warn_all_quiet_mode ()) - state - (make_loc right fuzz) - in - CilE.set_syntactic_context (CilE.SyMemLogic array_dst); - let new_state = - Relations_type.Model.add_binding - ~exact:false - ~with_alarms:(warn_all_quiet_mode ()) - new_state - (make_loc left fuzz) - garb - in - None, new_state, Location_Bits.get_bases right - end - | _ -> - raise Db.Value.Aborted - with - V.Not_based_on_null | Lmap.Cannot_copy | Db.Value.Aborted -> - Value_parameters.error - "Invalid call to Frama_C_memcpy%a" - pretty_actuals - actuals; - do_degenerate None; - raise Db.Value.Aborted + let size = match actuals with + | [_,size,_] -> size + | _ -> raise Invalid_CEA_alloc + in + let size = + try + let size = Cvalue.V.project_ival size in + Ival.project_int size + with Ival.Not_Singleton_Int | V.Not_based_on_null -> + raise Invalid_CEA_alloc + in + if Int.le size Int.zero then raise Invalid_CEA_alloc; + let new_name = Format.sprintf "Frama_C_alloc" in + let new_name = Cabs2cil.fresh_global new_name in + let bounded_type = + TArray( + charType, + Some (new_exp ~loc:Cil_datatype.Location.unknown + (Const (CInt64 (size,IInt ,None)))), + empty_size_cache (), + []) + in + let new_varinfo = makeGlobalVar ~logic:true new_name bounded_type in + let size_in_bits = Int.mul (Bit_utils.sizeofchar()) size in + let new_offsetmap = Cvalue.V_Offsetmap.sized_zero ~size_in_bits in + let new_base = + Cvalue.Default_offsetmap.create_initialized_var + new_varinfo + (Base.Known (Int.zero, Int.pred size_in_bits)) + new_offsetmap + in + let loc_without_size = Location_Bytes.inject new_base Ival.zero in + (wrap_ptr loc_without_size), + initial_state, + Location_Bits.Top_Param.bottom + with Ival.Error_Top | Invalid_CEA_alloc -> + Value_parameters.error + "Invalid argument for Frama_C_alloc_size function"; + do_degenerate None; + raise Db.Value.Aborted -let () = register_builtin "Frama_C_memcpy" frama_c_memcpy +let dump_state initial_state = + let l = fst (CurrentLoc.get ()) in + Value_parameters.result + "DUMPING STATE of file %s line %d@\n%a=END OF DUMP==" + l.Lexing.pos_fname l.Lexing.pos_lnum + Cvalue.Model.pretty initial_state; + None, initial_state, Location_Bits.Top_Param.bottom + +module DumpFileCounters = + State_builder.Hashtbl (Datatype.String.Hashtbl)(Datatype.Int) + (struct let size = 3 + let kind = `Correctness + let dependencies = [Db.Value.self] + let name = "Builtins.DumpFileCounters" + end) +let dump_state_file name initial_state args = + (try + let size = String.length name in + let name = + if size > 23 ( Frama_C_dump_each_file_ + 'something' ) then + String.sub name 23 (size - 23) + else failwith "no filename specified" + in + let n = try DumpFileCounters.find name with Not_found -> 0 in + DumpFileCounters.add name (n+1); + let file = Format.sprintf "%s_%d" name n in + let ch = open_out file in + let fmt = Format.formatter_of_out_channel ch in + let l = fst (CurrentLoc.get ()) in + Value_parameters.feedback ~current:true "Dumping state in file '%s'%t" + file Value_util.pp_callstack; + Format.fprintf fmt "DUMPING STATE at file %s line %d@." + l.Lexing.pos_fname l.Lexing.pos_lnum; + if args <> [] then Format.fprintf fmt "Args: %a@." pretty_actuals args; + Cvalue.Model.pretty fmt initial_state; + close_out ch + with e -> + Value_parameters.warning ~current:true ~once:true + "Error during, or invalid call to Frama_C_dump_each_file (%s). Ignoring" + (Printexc.to_string e) + ); + None, initial_state, Location_Bits.Top_Param.bottom + +let dump_args name initial_state actuals = + Value_parameters.result "Called %s%a%t" + name + pretty_actuals actuals + Value_util.pp_callstack; + None, initial_state, Location_Bits.Top_Param.bottom -( -let name_cea_offset = -let is_cea_offset name = name = name_cea_offset -) ( Local Variables: -compile-command: "LC_ALL=C make -C ../.." +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/value/current_table.ml frama-c-20111001+nitrogen+dfsg/src/value/current_table.ml --- frama-c-20110201+carbon+dfsg/src/value/current_table.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/current_table.ml 2011-10-10 08:38:26.000000000 +0000 @@ -25,43 +25,40 @@ open Cilutil open Cil_datatype -module Ki = Cil_datatype.Kinstr ( do not mask kinstr in src/value *) - type record = { - mutable superposition : State_imp.t ; - mutable widening : int ; - mutable widening_state : Relations_type.Model.t ; + mutable superposition : State_imp.t ; + mutable widening : int ; + mutable widening_state : Cvalue.Model.t ; } - + let empty_record () = { superposition = State_imp.empty () ; widening = Value_parameters.WideningLevel.get () ; - widening_state = Relations_type.Model.bottom } + widening_state = Cvalue.Model.bottom } - type t = record Ki.Hashtbl.t + type t = record Stmt.Hashtbl.t - let create () = - Ki.Hashtbl.create 257 + let create () = + Stmt.Hashtbl.create 257 - let clear t = Ki.Hashtbl.clear t + let clear t = Stmt.Hashtbl.clear t let find_current current_table kinstr = try - Ki.Hashtbl.find current_table kinstr + Stmt.Hashtbl.find current_table kinstr with Not_found -> let record = empty_record () in - Ki.Hashtbl.add current_table kinstr record; + Stmt.Hashtbl.add current_table kinstr record; record let find_widening_info current_table kinstr = let r = find_current current_table kinstr in r.widening, r.widening_state - let update_current_exn current_table kinstr v = - assert (kinstr <> Kglobal); - let record = find_current current_table kinstr in - State_imp.merge_set_into v record.superposition + let update_current_exn current_table stmt v = + let record = find_current current_table stmt in + State_imp.merge_set_into v record.superposition let update_current current_table kinstr v = @@ -72,20 +69,26 @@ let update_and_tell_if_changed current_table kinstr d = let record = find_current current_table kinstr in - State_imp.merge_set_return_new d record.superposition + if Cvalue.Model.is_reachable record.widening_state + then + let j = State_set.join d in + if Cvalue.Model.is_included j record.widening_state + then State_set.empty + else State_set.singleton j + else + State_imp.merge_set_return_new d record.superposition let update_widening_info current_table kinstr wcounter wstate = let record = find_current current_table kinstr in record.widening <- wcounter; - record.widening_state <- wstate; - record.superposition <- State_imp.singleton wstate + record.widening_state <- wstate let merge_db_table hash_states = - let treat_instr k sum = - let current_state = Db.Value.noassert_get_state k in + let treat_stmt k sum = + let current_state = Db.Value.noassert_get_stmt_state k in let is_top_already = - Relations_type.Model.is_top current_state + Cvalue.Model.is_top current_state in if not is_top_already then Db.Value.update_table k sum @@ -93,33 +96,39 @@ if Mark_noresults.should_memorize_function (Kernel_function.get_definition (Value_util.current_kf())) then - Ki.Hashtbl.iter treat_instr (Lazy.force hash_states) + Stmt.Hashtbl.iter treat_stmt (Lazy.force hash_states) let superpositions current_table = - let r = Ki.Hashtbl.create (Ki.Hashtbl.length current_table) + let r = Stmt.Hashtbl.create (Stmt.Hashtbl.length current_table) in - Ki.Hashtbl.iter + Stmt.Hashtbl.iter (fun k record -> - let sup2 = - State_imp.fold - State_set.add - record.superposition - State_set.empty - in - Ki.Hashtbl.add r k sup2) + let sup2 = + State_imp.fold + State_set.add + record.superposition + State_set.empty + in + Stmt.Hashtbl.add r k sup2) current_table; r let states current_table = - let r = Ki.Hashtbl.create (Ki.Hashtbl.length current_table) + let r = Stmt.Hashtbl.create (Stmt.Hashtbl.length current_table) in - Ki.Hashtbl.iter + Stmt.Hashtbl.iter (fun k record -> - Ki.Hashtbl.add r k - (State_imp.join_dropping_relations record.superposition)) + Stmt.Hashtbl.add r k + (Cvalue.Model.join + (State_imp.join_dropping_relations record.superposition) + record.widening_state)) current_table; r let find_superposition current_table s = - (find_current current_table s).superposition + let record = find_current current_table s in + let s = State_imp.to_set record.superposition in + if Cvalue.Model.is_reachable record.widening_state + then State_set.add record.widening_state s + else s diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval_exprs.ml frama-c-20111001+nitrogen+dfsg/src/value/eval_exprs.ml --- frama-c-20110201+carbon+dfsg/src/value/eval_exprs.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval_exprs.ml 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,1694 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types +open Cil +open Ast_printer +open Abstract_interp +open Locations +open Cvalue +open Bit_utils +open Value_util + + +exception Distinguishable_strings + +exception Leaf (* raised when nothing is known for a function : + no source nor specification ) + +exception Not_an_exact_loc + +exception Reduce_to_bottom + +exception Offset_not_based_on_Null of + Locations.Zone.t option Location_Bytes.t + +exception Cannot_find_lv + +exception Too_linear + + +type cond = + { exp: exp; (* The condition of the branch) + positive: bool; ( true: normal false: negated )} + +( Returns boolean telling to display a warning, + and optionally reduce the values of [ev1] and [ev2], + knowing that they are involved in a comparison ) +( TODO: this function currently never reduces ev1 and ev2 ) +let check_comparable op ev1 ev2 = + try + if not (Location_Bytes.is_included ev1 Location_Bytes.top_int) + || not (Location_Bytes.is_included ev2 Location_Bytes.top_int) + then begin + let null_1, rest_1 = Location_Bytes.split Base.null ev1 in + let null_2, rest_2 = Location_Bytes.split Base.null ev2 in + let is_bottom1 = Location_Bytes.is_bottom rest_1 in + let is_bottom2 = Location_Bytes.is_bottom rest_2 in + + ( First check if a non-zero integer is compared to an address ) + if ((not (Ival.is_included null_1 Ival.zero)) && (not is_bottom2)) + || ((not (Ival.is_included null_2 Ival.zero)) && (not is_bottom1)) + then raise Not_found; + + if not (is_bottom1 && is_bottom2) + then begin + let loc_bits1 = loc_bytes_to_loc_bits rest_1 in + let loc_bits2 = loc_bytes_to_loc_bits rest_2 in + let single_base_ok = + begin try + ( If they are both in the same base and both almost valid, + it's also fine, but beware of empty rest for comparisons + to NULL, or of function pointers ) + let extract_base is_bot loc = + if is_bot then Base.null + else begin + let base, offs = Location_Bits.find_lonely_key loc in + if Base.is_function base then + (if not (Ival.equal Ival.zero offs) + then raise Base.Not_valid_offset) + else + Base.is_valid_offset ~for_writing:false + Int.zero base offs; + base + end + in + let base_1 = extract_base is_bottom1 loc_bits1 + and base_2 = extract_base is_bottom2 loc_bits2 + in + is_bottom1 || is_bottom2 || (Base.equal base_1 base_2) + with + Not_found -> false + end + in + if not single_base_ok + then begin + if op = Eq || op = Ne + then begin + ( If both addresses are valid, they can be compared + for equality. ) + let loc1 = make_loc loc_bits1 Int_Base.one in + let loc2 = make_loc loc_bits2 Int_Base.one in + if (not (Locations.is_valid_or_function loc1)) || + (not (Locations.is_valid_or_function loc2)) + then raise Not_found; + ( But wait! literal strings can only be compared + if their contents are recognizably different! + (or the strings are physically the same) ) + Locations.Location_Bytes.iter_on_strings + ~skip:None + (fun base1 s1 offs1 len1 -> + Locations.Location_Bytes.iter_on_strings + ~skip:(Some base1) + (fun _ s2 offs2 len2 -> + let delta = offs1-offs2 in + begin + try + let start = if delta <= 0 then (-delta) else 0 + in + for i = start to min len2 (len1 - delta) + do +( Format.printf "%S %S %d %d@." + s1 s2 i delta; ) + if s2.[i] <> s1.[i + delta] + then raise Distinguishable_strings; + done; + raise Not_found + with Distinguishable_strings -> (); + end) + rest_1) + rest_2 + end + else raise Not_found + end + end + end; + false, ev1, ev2 + with Not_found | Base.Not_valid_offset -> + true, ev1, ev2 + +let do_cast ~with_alarms t expr = + let treat inttype = + match inttype with + | TInt(kind,_) -> + let size = Int.of_int (bitsSizeOf inttype) in + let signed = isSigned kind in + V.cast ~with_alarms ~signed ~size expr + | TFloat (FFloat,_) -> + let addresses, overflow, res = V.cast_float expr in + if addresses + then warning_once_current + "addresses in float"; + if overflow then warning_once_current + "overflow in float: %a -> %a. assert(Ook)" + V.pretty expr V.pretty res; + res + | TFloat (FDouble,_) + | TFloat (FLongDouble,_) -> + expr + | _ -> assert false + in + match unrollType t with + | TInt _ | TFloat _ as t' -> + treat t' + | TPtr _ -> + treat theMachine.upointType + | TEnum ({ekind=k},_) -> treat (TInt(k,[])) + | TComp _ -> expr ( see test [struct_call.c] ) + | TBuiltin_va_list _ -> + (match with_alarms.CilE.imprecision_tracing with + | CilE.Aignore -> () + | CilE.Acall f -> f () + | CilE.Alog _ -> + warning_once_current + "cast to __builtin_va_list is not precisely implemented yet"); + V.topify_arith_origin expr + | TFun _ -> expr + | TNamed _ -> assert false + | TVoid _ -> assert false + | TArray _ -> assert false + +let do_promotion ~with_alarms ~src_typ ~dest_type v e_src = + match dest_type, src_typ with + | TFloat _, TInt _ -> + Cvalue.V.cast_int_to_float ~with_alarms (get_rounding_mode()) v + | TInt (kind,_), TFloat _ -> + let size = bitsSizeOf dest_type in + let signed = isSigned kind in + let alarm_use_as_float, alarm_overflow, r = + Cvalue.V.cast_float_to_int ~signed ~size v + in + if alarm_use_as_float + then begin + warning_once_current + "converting %a to float: assert(Ook)" + !d_exp e_src; + end; + if alarm_overflow + then + warning_once_current + "Overflow in cast of %a (%a) from floating-point to integer: assert(Ook)" + !d_exp e_src + Cvalue.V.pretty v; + r + | _, _ -> v + +let handle_signed_overflow ~with_alarms typ interpreted_e = + match unrollType typ with + TInt(kind, _) + when isSigned kind -> + let size = bitsSizeOf typ in + let mn, mx = + let b = Int.power_two (size-1) in + Int.neg b, Int.pred b + in + let mn64 = Int.to_int64 mn in + let mx64 = Int.to_int64 mx in + let warn_under, warn_over = + try + let i = V.project_ival interpreted_e in + let imn, imx = Ival.min_and_max i in + let u = + match imn with + Some bound when Int.ge bound mn -> None + | _ -> Some mn64 + in + let o = + match imx with + Some bound when Int.le bound mx -> None + | _ -> Some mx64 + in + u, o + with V.Not_based_on_null -> + Some mn64, Some mx64 + in + ( match warn_under, warn_over with + None, None -> + interpreted_e + | _ -> + if Value_parameters.SignedOverflow.get() + then + let all_values = + Cvalue.V.inject_ival + (Ival.inject_range (Some mn) (Some mx)) + in + CilE.warn_signed_overflow + with_alarms + warn_under + warn_over; + V.narrow all_values interpreted_e + else + ( warning_once_current + "2's complement assumed for overflow"; + interpreted_e ) ) + | _ -> interpreted_e + +let warn_lval_read lv loc contents = + let pretty_param fmt param = + match param with + | Location_Bits.Top_Param.Top -> Format.fprintf fmt "is imprecise" + | Location_Bits.Top_Param.Set _s -> + Format.fprintf fmt "is a garbled mix of %a" + Location_Bits.Top_Param.pretty param + in + let pretty_param_b fmt param = + match param with + | Location_Bytes.Top_Param.Top -> + Format.fprintf fmt "The contents@ are imprecise" + | Location_Bytes.Top_Param.Set _s -> + Format.fprintf fmt "It contains@ a garbled@ mix@ of@ %a" + Location_Bytes.Top_Param.pretty param + in + let something_to_warn = + match loc.loc with Location_Bits.Top _ -> true + | Location_Bits.Map _ -> + match contents with + | Location_Bytes.Top _ -> true + | Location_Bytes.Map _ -> false + in + if something_to_warn then + Value_parameters.result ~current:true ~once:true + "@[<v>@[Reading left-value %a.@]@ %t%t%t@]" + !Ast_printer.d_lval lv + (fun fmt -> + match lv with + | Mem _, _ -> + (match loc.loc with + | Location_Bits.Top (param,o) when Origin.equal o Origin.top -> + Format.fprintf fmt "@[The location %a.@]@ " + pretty_param param + | Location_Bits.Top (param,orig) -> + Format.fprintf fmt "@[The location @[%a@]@ because of@ %a.@]@ " + pretty_param param + Origin.pretty orig + | Location_Bits.Map _ -> + Format.fprintf fmt "@[The location is @[%a@].@]@ " + Location_Bits.pretty loc.loc) + | Var _, _ -> ()) + (fun fmt -> + match contents with + | Location_Bytes.Top (param,o) when Origin.equal o Origin.top -> + Format.fprintf fmt "@[%a.@]" + pretty_param_b param + | Location_Bytes.Top (param,orig) -> + Format.fprintf fmt "@[%a@ because of@ %a.@]" + pretty_param_b param + Origin.pretty orig + | Location_Bytes.Map _ -> ()) + pp_callstack + +let eval_binop_float ~with_alarms ev1 op ev2 = + try + let conv v = + try Ival.project_float (V.project_ival v) + with + | V.Not_based_on_null + | Ival.Float_abstract.Nan_or_infinite -> + warning_once_current "converting value to float: assert(Ook)"; + Ival.Float_abstract.top + in + let f1 = conv ev1 + and f2 = conv ev2 + in + let binary_float_floats (_name: string) f = + try + let alarm, f = f (get_rounding_mode ()) f1 f2 in + if alarm then CilE.warn_result_nan_infinite with_alarms; + V.inject_ival (Ival.inject_float f) + with + | Ival.Float_abstract.Nan_or_infinite -> + CilE.warn_result_nan_infinite with_alarms ; + V.top_float + | Ival.Float_abstract.Bottom -> + CilE.warn_result_nan_infinite with_alarms ; + V.bottom + in + begin match op with + | PlusA -> binary_float_floats "+." Ival.Float_abstract.add_float + | MinusA -> binary_float_floats "-." Ival.Float_abstract.sub_float + | Mult -> binary_float_floats "." Ival.Float_abstract.mult_float + | Div -> binary_float_floats "/." Ival.Float_abstract.div_float + | Eq -> + let contains_zero, contains_non_zero = + Ival.Float_abstract.equal_float_ieee f1 f2 + in + V.interp_boolean ~contains_zero ~contains_non_zero + | Ne -> + let contains_non_zero, contains_zero = + Ival.Float_abstract.equal_float_ieee f1 f2 + in + V.interp_boolean ~contains_zero ~contains_non_zero + | Lt -> + V.interp_boolean + ~contains_zero:(Ival.Float_abstract.maybe_le_ieee_float f2 f1) + ~contains_non_zero:(Ival.Float_abstract.maybe_lt_ieee_float f1 f2) + | Le -> + V.interp_boolean + ~contains_zero:(Ival.Float_abstract.maybe_lt_ieee_float f2 f1) + ~contains_non_zero:(Ival.Float_abstract.maybe_le_ieee_float f1 f2) + | Gt -> + V.interp_boolean + ~contains_zero:(Ival.Float_abstract.maybe_le_ieee_float f1 f2) + ~contains_non_zero:(Ival.Float_abstract.maybe_lt_ieee_float f2 f1) + | Ge -> + V.interp_boolean + ~contains_zero:(Ival.Float_abstract.maybe_lt_ieee_float f1 f2) + ~contains_non_zero:(Ival.Float_abstract.maybe_le_ieee_float f2 f1) + | _ -> raise V.Not_based_on_null + end + with V.Not_based_on_null | Ival.F.Nan_or_infinite -> + warning_once_current + "float operation on address."; + V.join + (V.topify_arith_origin ev1) + (V.topify_arith_origin ev2) + +(* eval some operations on location_bytes. This function is more low-level + than eval_binop, that evaluates the expressions in the given state. Here, + we suppose someone else has done the evaluation, and combine the results. + The expressions are passed in order to have the types of the expressions + at hand; hopefully they are correct. [typ] is optional. If it is not + passed, the function must behave as if it was acting on unbounded integers ) +let eval_binop_int ~with_alarms ?typ ~te1 ev1 op ev2 = + match op with + | PlusPI | IndexPI -> V.add_untyped (osizeof_pointed te1) ev1 ev2 + | MinusPI -> V.add_untyped (Int_Base.neg (osizeof_pointed te1)) ev1 ev2 + | PlusA -> V.add_untyped (Int_Base.one) ev1 ev2 + | MinusA -> V.add_untyped Int_Base.minus_one ev1 ev2 + | MinusPP -> + let minus_val = V.add_untyped Int_Base.minus_one ev1 ev2 in + begin + try + let size = Int_Base.project (sizeof_pointed te1) in + let size = Int.div size Int.eight in + if Int.is_one size then + minus_val + else + let minus_val = Cvalue.V.project_ival minus_val in + Cvalue.V.inject_ival (Ival.scale_div ~pos:true size minus_val) + with + | Int_Base.Error_Top + | Cvalue.V.Not_based_on_null + | Not_found -> + V.join (V.topify_arith_origin ev1) (V.topify_arith_origin ev2) + end + | Mod -> V.c_rem ~with_alarms ev1 ev2 + | Div -> V.div ~with_alarms ev1 ev2 + | Mult -> V.arithmetic_function ~with_alarms "" Ival.mul ev1 ev2 + | LOr -> + assert false + (* This code makes a strict evaluation: V.interp_boolean + ~contains_zero: (V.contains_zero ev1 && + V.contains_zero ev2) ~contains_non_zero: + (V.contains_non_zero ev1 || V.contains_non_zero + ev2)) + | LAnd -> + assert false + ( This code makes a strict evaluation: + V.interp_boolean ~contains_zero: (V.contains_zero + ev1 || V.contains_zero ev2) ~contains_non_zero: + (V.contains_non_zero ev1 && V.contains_non_zero + ev2)) + | BXor -> + V.oper_on_values ~with_alarms "^" Int.logxor ev1 ev2 + | BOr -> + V.bitwise_or ~size:(bitsSizeOf te1) ev1 ev2 + | BAnd -> + (try + let size = bitsSizeOf te1 in + let signed = is_signed_int_enum_pointer te1 in + V.bitwise_and ~size ~signed ev1 ev2 + with SizeOfError _ -> + V.join (V.topify_arith_origin ev1) (V.topify_arith_origin ev2)) + + | Eq | Ne | Ge | Le | Gt | Lt -> + let warn, ev1, ev2 = check_comparable op ev1 ev2 in + if warn then CilE.warn_pointer_comparison with_alarms; + if warn && Value_parameters.UndefinedPointerComparisonPropagateAll.get () + then V.zero_or_one + else + let signed = is_signed_int_enum_pointer (unrollType te1) in + let f = match op with + | Eq -> V.check_equal true + | Ne -> V.check_equal false + | Ge -> V.comparisons ">=" ~signed V.do_ge + | Le -> V.comparisons "<=" ~signed V.do_le + | Gt -> V.comparisons ">" ~signed V.do_gt + | Lt -> V.comparisons "<" ~signed V.do_lt + | _ -> assert false + in + f ev1 ev2 + | Shiftrt | Shiftlt -> + begin + let f = + if op = Shiftlt then V.shift_left else V.shift_right + in + try + let size = Extlib.opt_map bitsSizeOf typ in + f ~with_alarms ?size ev1 ev2 + with SizeOfError _ -> assert false + end + +( TODO: A version that does not create bigints would be better ) +let bitfield_size_lv lv = sizeof (typeOfLval lv) +let bitfield_size_bf lv = Bit_utils.sizeof_lval lv +let is_bitfield lv ?(sizelv=bitfield_size_lv lv) ?(sizebf=(bitfield_size_bf lv)) () = + not (Int_Base.equal sizelv sizebf) + +let rec lval_to_loc ~with_alarms state lv = + let _,_,r = + lval_to_loc_deps_option + ~with_alarms + ~deps:None + ~reduce_valid_index:(Kernel.SafeArrays.get ()) + state + lv + in + r + +and exp_lval_to_loc state exp = + let lv = + match exp.enode with + | Lval lv -> lv + | _ -> raise Cannot_find_lv + in + ( TODO: utiliser find_lv_plus pour traiter plus d'expressions ) + lv, lval_to_loc ~with_alarms:CilE.warn_none_mode state lv + +and lval_to_loc_deps_option + ~with_alarms ~deps state ~reduce_valid_index (base,offset as lv) + = + if not (Cvalue.Model.is_reachable state) then + state, deps, loc_bottom + else + let typ = match base with + | Var host -> host.vtype + | Mem x -> typeOf x + in + try + let state, deps, offs = + eval_offset + ~reduce_valid_index + ~with_alarms deps typ state offset + in + base_to_loc ~with_alarms ?deps state lv base offs + with Offset_not_based_on_Null(deps,offset) -> + let state, deps, loc_if_there_wasnt_offset = + base_to_loc ~with_alarms ?deps state lv base Ival.zero + in + state, deps, + loc_bits_to_loc lv + (Location_Bits.join + (loc_bytes_to_loc_bits offset) + loc_if_there_wasnt_offset.loc) + +( pc says: only called in addrOf ) +and lval_to_loc_with_offset_deps_only ~deps state v = + lval_to_loc_with_offset_deps_only_option ~deps:(Some deps) state v + +and lval_to_loc_with_deps ~deps state lv ~with_alarms = + lval_to_loc_deps_option ~with_alarms ~deps:(Some deps) state lv + +( pc says: only called in addrOf *) +and lval_to_loc_with_offset_deps_only_option + ~with_alarms ~deps (state:Cvalue.Model.t) (_base, _offset as v) + = + lval_to_loc_deps_option + ~with_alarms ~deps (state:Cvalue.Model.t) (v) + ~reduce_valid_index:false + + +(** Detects if an expression can be considered as a lvalue even though + it is hidden by a cast that does not change the lvalue. + Raises [exn] if it is not an lvalue. + + TODO: When the goal is to recognize the form (cast)l-value == expr, + it would be better and more powerful to have chains of inverse functions ) + +and pass_cast ~with_alarms state exn typ e = + ( type might be the same but their attributes. + But volatile attribute cannot be skipped ) + if not (Cilutil.equals + (typeSigWithAttrs (filterAttributes "volatile") typ) + (typeSigWithAttrs (filterAttributes "volatile") (typeOf e))) + then + (try + let typeofe = typeOf e in + ( Any volatile attribute may have an effect on the expression value ) + if hasAttribute "volatile" (typeAttrs typeofe) + || hasAttribute "volatile" (typeAttrs typ) + then raise exn; + let sztyp = sizeof typ in + let szexpr = sizeof typeofe in + let typ_ge_typeofe = + match sztyp,szexpr with + Int_Base.Value styp, Int_Base.Value sexpr -> Int.ge styp sexpr + | _ -> false + in + if not typ_ge_typeofe then raise exn; + let sityp = is_signed_int_enum_pointer typ in + let sisexpr = is_signed_int_enum_pointer (typeOf e) in + if sityp = sisexpr then () + ( destination type is larger and has the same sign as + the original type ) + else begin ( try to ignore the cast if it acts as identity + on the value [e] even if signed/unsigned + conflict. ) + match unrollType typ with + | TInt _ | TEnum _ -> + let size = Int.of_int (bitsSizeOf typ) in + let signed = sityp in + (try + let old_ival = V.project_ival + (eval_expr ~with_alarms state e) + in + if (Ival.equal + old_ival + (Ival.cast ~size ~signed ~value:old_ival)) + then () ( [e] is not sensitive to cast ) + else raise exn + with + | Not_found + | V.Not_based_on_null -> + raise exn) + ( this is not always injective, thus cannot be + easily reverted. ) + | _ -> raise exn + end + with Neither_Int_Nor_Enum_Nor_Pointer + -> raise exn) + +and find_lv ~with_alarms (state:Cvalue.Model.t) ee = + ( [BM] Do not recognize an lval whenever a volatile is involved to + prevent copy/paste optimization. IS THIS THE RIGHTPLACE PC ?) + if hasAttribute "volatile" (typeAttrs (typeOf ee)) then + raise Cannot_find_lv; + match ee.enode with + | Lval lv -> lv + | CastE (typ,e) -> + ( match unrollType typ, unrollType (typeOf e) with + TFloat (FDouble,_), TFloat _ -> find_lv ~with_alarms state e + ( see remark at pass_cast about inverse functions ) + | _ -> + pass_cast ~with_alarms state Cannot_find_lv typ e; + find_lv ~with_alarms state e) + | _ -> raise Cannot_find_lv + +and find_lv_plus ~with_alarms state e = + let acc = ref [] in + let rec find_lv_plus_rec e current_offs = + try + let lv = find_lv ~with_alarms state e in + if not (hasAttribute "volatile" (typeAttrs (Cil.typeOfLval lv))) + then acc := (lv,current_offs) :: !acc + with Cannot_find_lv -> + match e.enode with + BinOp(op, e1, e2, typ) -> + begin + match unrollType typ with + TFloat _ -> () + | _ -> begin + match op with + PlusA -> + let ev1 = eval_expr ~with_alarms state e1 in + let ev2 = eval_expr ~with_alarms state e2 in + ( try + let ival1 = V.project_ival ev1 in + find_lv_plus_rec e2 (Ival.add current_offs ival1) + with V.Not_based_on_null -> ()); + ( try + let ival2 = V.project_ival ev2 in + find_lv_plus_rec e1 (Ival.add current_offs ival2) + with V.Not_based_on_null -> ()); + | (MinusA|MinusPI|PlusPI|IndexPI as b) -> + let ev2 = eval_expr ~with_alarms state e2 in + ( try + let ival2 = V.project_ival ev2 in + let ival2 = + if b = MinusA + then ival2 + else + let ival2 = + Ival.scale + (Int_Base.project (osizeof_pointed typ)) + ival2 + in + if b = MinusPI + then ival2 + else Ival.neg ival2 + in + find_lv_plus_rec e1 (Ival.sub current_offs ival2) + with V.Not_based_on_null | Int_Base.Error_Top-> ()); + | _ -> () + end + end + | CastE(typ,e) -> + ( try + pass_cast ~with_alarms state Cannot_find_lv typ e; + find_lv_plus_rec e current_offs + with Cannot_find_lv -> ()) + | _ -> () + in + find_lv_plus_rec e Ival.singleton_zero; + (List.iter + (fun (lv,ival) -> + ignore (Pretty.printf "find_lv_plus %a : %s\n" + d_lval lv + (pretty_to_string Ival.pretty ival))) + !acc;) + !acc + +and base_to_loc ~with_alarms ?deps state lv base offs = + if Ival.is_bottom offs + then begin + Cvalue.Model.bottom, + (Some Zone.bottom), + loc_bits_to_loc lv Location_Bits.bottom + end + else + let result = match base with + | Var host -> + let base = Base.find host in + state, deps, + loc_bits_to_loc lv (Location_Bits.inject base offs) + | Mem x -> + let state, deps, loc_lv = + eval_expr_with_deps_state ~with_alarms deps state x + in + let loc_bits = + Location_Bits.location_shift + offs + (loc_bytes_to_loc_bits loc_lv) + in + state, deps, loc_bits_to_loc lv loc_bits + in + CilE.set_syntactic_context (CilE.SyMem lv); + result + +and eval_expr ~with_alarms state e = + snd (eval_expr_with_deps ~with_alarms None state e) + +and get_influential_vars ~with_alarms state cond = + ( Format.printf "get_influential cond:%a@.state:%a@." + !d_exp cond + Cvalue.Model.pretty state; ) + let rec get_vars acc cond = + match cond.enode with + | Lval (Var v, off as lv) -> + let offset = + try + let _, _, offset = + eval_offset ~reduce_valid_index:true ~with_alarms None + v.vtype state off + in + offset + with Offset_not_based_on_Null _ -> + Ival.top + in + if Ival.cardinal_zero_or_one offset + then + ( no variable in offset can be influential ) + let varid = Base.create_varinfo v in + let loc = + Locations.make_loc + (Locations.Location_Bits.inject varid offset) + (sizeof_lval lv) + in + let contents = + Cvalue.Model.find ~conflate_bottom:true + state ~with_alarms loc + in + if Location_Bytes.cardinal_zero_or_one contents + then ( + ( Format.printf "cond:%a@.var contents:%a@.state:%a@." + !d_exp cond + Location_Bytes.pretty contents + Cvalue.Model.pretty state; ) + acc ( it's not influential ) + ) + else loc :: acc + else + ( a variable in offset can be influential ) + get_vars_offset acc off + | Lval (Mem e, off) -> + get_vars_offset (get_vars acc e) off + | BinOp(_,v1,v2,_) -> + get_vars (get_vars acc v1) v2 + | UnOp(_,v1,_) -> + get_vars acc v1 + | CastE (_typ,exp) -> + get_vars acc exp + | _ -> acc + and get_vars_offset acc offset = + match offset with + NoOffset -> acc + | Field (_,off) -> get_vars_offset acc off + | Index (ind,off) -> get_vars (get_vars_offset acc off) ind + in + get_vars [] cond + +and reduce_by_valid_expr ~positive ~for_writing exp state = + try + let lv, loc = exp_lval_to_loc state exp in + if not (Locations.valid_cardinal_zero_or_one ~for_writing:false loc) + then state + else reduce_by_valid_loc ~positive ~for_writing loc (typeOfLval lv) state + with Cannot_find_lv -> state + +and reduce_by_valid_loc ~positive ~for_writing loc typ state = + try + let value = Cvalue.Model.find ~with_alarms:CilE.warn_none_mode + ~conflate_bottom:true state loc + in + if Cvalue.V.is_imprecise value then + ( we won't reduce anything anyway, and we may lose information if loc + contains misaligned data ) + raise Cannot_find_lv; + let value_as_loc = + make_loc (loc_bytes_to_loc_bits value) (sizeof_pointed typ) + in + let reduced_value = + loc_to_loc_without_size + (if positive + then valid_part ~for_writing value_as_loc + else invalid_part value_as_loc ) + in + if Location_Bytes.equal value reduced_value + then state + else begin + if Location_Bytes.equal Location_Bytes.bottom reduced_value + then Cvalue.Model.bottom + else + Cvalue.Model.reduce_binding ~with_alarms:CilE.warn_none_mode + state loc reduced_value + end + with Cannot_find_lv -> state + +and reduce_by_initialized_loc ~with_alarms:_ ~positive (typ, loc) state = + try + let locbi = loc_bytes_to_loc_bits loc in + let size = match unrollType typ with + | TPtr (t, _) -> bitsSizeOf t + | _ -> assert false + in + let loc = make_loc locbi (Int_Base.inject (Int.of_int size)) in + if not (Locations.valid_cardinal_zero_or_one ~for_writing:false loc) + then state + else + let value = Cvalue.Model.find_unspecified + ~with_alarms:CilE.warn_none_mode state loc + in + (match value with + | Cvalue.V_Or_Uninitialized.C_uninit_esc (Location_Bytes.Top _) + | Cvalue.V_Or_Uninitialized.C_uninit_noesc (Location_Bytes.Top _) + | Cvalue.V_Or_Uninitialized.C_init_esc (Location_Bytes.Top _) + | Cvalue.V_Or_Uninitialized.C_init_noesc (Location_Bytes.Top _) -> + ( we won't reduce anything anyway, + and we may lose information if loc contains misaligned data ) + raise Cannot_find_lv + | _ -> () ); + let reduced_value = + Cvalue.V_Or_Uninitialized.change_initialized positive value + in + if Cvalue.V_Or_Uninitialized.equal value reduced_value + then state + else begin + if Cvalue.V_Or_Uninitialized.equal + Cvalue.V_Or_Uninitialized.bottom reduced_value + then Cvalue.Model.bottom + else + Cvalue.Model.add_binding_unspecified + state + loc + reduced_value + end + with Cannot_find_lv -> state + +and eval_BinOp ~with_alarms e deps state = + match e.enode with + | BinOp (op, e1, e2, typ) -> + let state, deps, ev1 = + eval_expr_with_deps_state ~with_alarms deps state e1 + in + if V.is_bottom ev1 + then Cvalue.Model.bottom, (Some Zone.bottom) ,V.bottom + else + let state, deps, ev2 = + eval_expr_with_deps_state ~with_alarms deps state e2 + in + if V.is_bottom ev2 + then Cvalue.Model.bottom, (Some Zone.bottom) ,V.bottom + else begin + begin match unrollType (typeOf e1) with + | TFloat _ -> + CilE.set_syntactic_context (CilE.SyUnOp e); + let r = eval_binop_float ~with_alarms ev1 op ev2 in + state, deps, r + | TInt _ | TPtr (_, _) | _ as te1 -> + CilE.set_syntactic_context (CilE.SyBinOp (op, e1, e2)); + let v = eval_binop_int + ~with_alarms ~typ ~te1 ev1 op ev2 in + ( Warn if overflow in a signed int binop ) + let v = match op with + | Shiftlt | Mult | MinusPP | MinusPI | IndexPI | PlusPI + | PlusA | Div | Mod | MinusA -> + handle_signed_overflow ~with_alarms typ v + | _ -> v + in + state, deps, v + end + end + | _ -> assert false + +and eval_expr_with_deps ~with_alarms deps (state : Cvalue.Model.t) e = + let _,deps,r = eval_expr_with_deps_state ~with_alarms deps state e in + deps, r + +and eval_expr_with_deps_state ~with_alarms deps state e = + let state, deps, r = + let orig_expr = Cil.stripInfo e in + match orig_expr.enode with + | Info _ -> assert false + | Const v -> + let r = + begin match v with + | CInt64 (i,_k,_s) -> + V.inject_int i + | CChr c -> + (match charConstToInt c with + | CInt64 (i,_,_) -> V.inject_int i + | _ -> assert false) + | CReal (f, _fsize, _) -> + Value_parameters.result ~once:true + "float support is experimental"; + let f = Ival.F.of_float f in + let overflow, af = + try + let o, af = Ival.Float_abstract.inject_r f f in + o, V.inject_ival (Ival.inject_float af) + with Ival.Float_abstract.Bottom -> + Value_parameters.result ~current:true + "Floating-point literal (or constant expression) is not finite. This path is assumed to be dead."; + true, V.bottom + in + if overflow + then Value_parameters.result "overflow in constant: assert(Ook);"; + af + | CWStr _ | CStr _ -> + V.inject (Base.create_string orig_expr) Ival.zero + | CEnum {eival = e} -> + eval_expr ~with_alarms state e + end + in + state, deps, r + | BinOp _ -> + eval_BinOp ~with_alarms orig_expr deps state + | Lval lv -> + eval_lval ~conflate_bottom:true ~with_alarms deps state lv + | AddrOf v | StartOf v -> + let state, deps, r = + lval_to_loc_with_offset_deps_only_option ~with_alarms ?deps state v + in + state, deps, loc_to_loc_without_size r + + | CastE (typ, e) -> + let deps, evaled_expr = + eval_expr_with_deps ~with_alarms deps state e + in + let src_typ = unrollType (typeOf e) in + let dest_type = unrollType typ in + let r = do_promotion ~with_alarms ~dest_type ~src_typ evaled_expr e in + state, deps, r + + | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> + let e = Cil.constFold true orig_expr in + let r = match e.enode with + | Const (CInt64 (v, _, _)) -> Cvalue.V.inject_int v + | _ -> + Value_parameters.error ~current:true + "cannot interpret sizeof or alignof (incomplete type)"; + V.top_int + in + state, deps, r + + | UnOp (op, e, _t_res) -> + let t = unrollType (typeOf e) in + let deps, expr = eval_expr_with_deps ~with_alarms deps state e in + let syntactic_context = match op with + | Neg -> CilE.SyUnOp orig_expr ( Can overflow ) + | BNot -> CilE.SyUnOp orig_expr ( does in fact never raise an alarm) + | LNot -> CilE.SyBinOp (Eq, Cil.zero ~loc:e.eloc, e) + ( Can raise a pointer comparison. CilE needs a binop there ) + in + CilE.set_syntactic_context syntactic_context; + let result = eval_unop ~with_alarms expr t op in + state, deps, result + in + let r = + if hasAttribute "volatile" (typeAttrs (typeOf e)) + && not (Cvalue.V.is_bottom r) + then V.top_int + else + r + in + let typ = typeOf e in + let rr = do_cast ~with_alarms typ r in +( ( match typ with + TInt _ when not (V.equal r rr || V.is_topint r) -> + warning_once_current + "downcast %a -> %a@." V.pretty r V.pretty rr + | _ -> ()); ) + state, deps, rr + +and eval_unop ~with_alarms expr t op = + match op with + | Neg -> + let t = unrollType t in + (match t with TFloat _ -> + (try + let v = V.project_ival expr in + let f = Ival.project_float v in + V.inject_ival + (Ival.inject_float (Ival.Float_abstract.neg_float f)) + with + V.Not_based_on_null -> + begin match with_alarms.CilE.others with + CilE.Aignore -> () + | CilE.Acall f -> f() + | CilE.Alog _ -> + warning_once_current + "converting address to float: assert(TODO)" + end; + V.topify_arith_origin expr + | Ival.Float_abstract.Nan_or_infinite -> + begin match with_alarms.CilE.others with + CilE.Aignore -> () + | CilE.Acall f -> f() + | CilE.Alog _ -> + warning_once_current + "converting value to float: assert (TODO)" + end; + V.top_float + ) + | _ -> + let result = + try + let v = V.project_ival expr in + V.inject_ival (Ival.neg v) + with V.Not_based_on_null -> V.topify_arith_origin expr + in + handle_signed_overflow ~with_alarms t result + ) + + | BNot -> + (try + let v = V.project_ival expr in + V.inject_ival + (Ival.apply_set_unary "~" Int.lognot v) + with V.Not_based_on_null -> V.topify_arith_origin expr) + + | LNot -> + ( TODO: on float, LNot is equivalent to == 0.0 ) + let warn, _, expr = check_comparable Eq V.singleton_zero expr in + if warn then CilE.warn_pointer_comparison with_alarms; + if (warn && + Value_parameters.UndefinedPointerComparisonPropagateAll.get ()) + || not (isIntegralType t || isPointerType t) + then + V.zero_or_one + else + V.interp_boolean + ~contains_zero:(V.contains_non_zero expr) + ~contains_non_zero:(V.is_included V.singleton_zero expr) + +and eval_expr_with_deps_state_subdiv ~with_alarms deps state e = + let (state_without_subdiv, deps_without_subdiv, result_without_subdiv as r) = + eval_expr_with_deps_state ~with_alarms deps state e + in + let subdivnb = Value_parameters.Subdivide_float_in_expr.get() in + if subdivnb=0 + then r + else if not (Locations.Location_Bytes.is_included result_without_subdiv Locations.Location_Bytes.top_int) + then begin + Value_parameters.debug ~level:2 + "subdivfloatvar: expression has an address result"; + r + end + else + let compare_min, compare_max = + if Locations.Location_Bytes.is_included result_without_subdiv Locations.Location_Bytes.top_float + then begin + Value_parameters.debug ~level:2 + "subdivfloatvar: optimizing floating-point expression %a=%a" + !d_exp e + Locations.Location_Bytes.pretty result_without_subdiv; + Cvalue.V.compare_min_float, Cvalue.V.compare_max_float + end + else begin + Value_parameters.debug ~level:2 + "subdivfloatvar: optimizing integer expression %a=%a" + !d_exp e + Locations.Location_Bytes.pretty result_without_subdiv; + Cvalue.V.compare_min_int, Cvalue.V.compare_max_int + end + in + let vars = + get_influential_vars ~with_alarms:CilE.warn_none_mode state e + in + Value_parameters.debug ~level:2 "subdivfloatvar: variable list=%a" + (Pretty_utils.pp_list Locations.pretty) + vars; + let rec try_sub vars = + match vars with + | [] | [ _ ] -> r + | v :: tail -> + try + if not (List.exists (fun x -> Locations.loc_equal v x) tail) + then raise Too_linear; + let v_value = + Cvalue.Model.find + ~conflate_bottom:true + ~with_alarms:CilE.warn_none_mode + state + v + in + ( Value_parameters.result ~current:true + "subdivfloatvar: considering optimizing variable %a (value %a)" + Locations.pretty v Cvalue.V.pretty v_value; ) + if not (Locations.Location_Bytes.is_included + v_value + Locations.Location_Bytes.top_float) + then raise Too_linear; + + let working_list = ref [ (v_value, result_without_subdiv) ] in + let had_bottom = ref false in + let subdiv_for_bound better_bound = + let rec insert_subvalue_in_list (_, exp_value as p) l = + match l with + [] -> [p] + | (_, exp_value1 as p1) :: tail -> + if better_bound exp_value1 exp_value >= 0 + then p :: l + else p1 :: (insert_subvalue_in_list p tail) + in + let exp_subvalue subvalue l = + let substate = + ( FIXME: should be relation-aware primitive ) + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + v + subvalue + in + let subexpr = eval_expr ~with_alarms substate e in +( Value_parameters.result ~current:true + "subdivfloatvar: computed var=%a expr=%a" + V.pretty subvalue + V.pretty subexpr; ) + if Cvalue.V.is_bottom subexpr + then begin + had_bottom := true; + l + end + else + insert_subvalue_in_list (subvalue, subexpr) l + in + let size = + if Value_parameters.AllRoundingModes.get () + then 0 + else Int.to_int (Int_Base.project v.Locations.size) + in + let subdiv l = + match l with + [] -> + Value_parameters.debug + "subdivfloatvar: all reduced to bottom!!"; + raise Ival.Can_not_subdiv + | (value, _exp_value) :: tail -> + let (subvalue1, subvalue2) = + Cvalue.V.subdiv_float_interval ~size value + in + let s = exp_subvalue subvalue1 tail + in + exp_subvalue subvalue2 s + in + try + for i = 1 to subdivnb do + working_list := subdiv !working_list; + done + with Ival.Can_not_subdiv -> () + in + subdiv_for_bound compare_min ; + ( Now sort working_list in decreasing order + on the upper bounds of exp_value ) + let comp_exp_value (_value1,exp_value1) (_value2,exp_value2) = + compare_max exp_value1 exp_value2 + in + working_list := List.sort comp_exp_value !working_list ; + if Value_parameters.debug_atleast 2 then + List.iter + (function (x, e) -> + Value_parameters.debug + "subdivfloatvar: elements of list max %a %a" + V.pretty x V.pretty e) + !working_list; + subdiv_for_bound compare_max ; + let working_list = !working_list in + if Value_parameters.debug_atleast 2 then + List.iter + (function (x, e) -> + Value_parameters.debug + "subdivfloatvar: elements of final list %a %a" + V.pretty x V.pretty e) + working_list; + let reduced_state, optimized_exp_value = + if !had_bottom + then + let reduced_var, optimized_exp_value = + List.fold_left + (fun (accv,acce) (value, exp_value) -> + Cvalue.V.join value accv, + Cvalue.V.join exp_value acce) + (Cvalue.V.bottom, + Cvalue.V.bottom) + working_list + in + ( FIXME: should be relation-aware primitive ) + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + v + reduced_var, + optimized_exp_value + else + state_without_subdiv, + List.fold_left + (fun acc (_value, exp_value) -> + Cvalue.V.join exp_value acc) + Cvalue.V.bottom + working_list + in + reduced_state, deps_without_subdiv, optimized_exp_value + with Not_less_than | Too_linear -> + try_sub tail + in + try_sub vars + +( TODO. Cf also [Eval_stmts.do_assign_abstract_value_to_loc]. Should we check + that the value is an int, and topify otherwise ? ) +and cast_lval_bitfield lv size v = + let signed = signof_typeof_lval lv in + Cvalue.V.cast ~with_alarms:CilE.warn_none_mode ~size ~signed v + +and cast_lval_when_bitfield lv ?(sizelv=bitfield_size_lv lv) ?(sizebf=(bitfield_size_bf lv)) v = + match sizebf with + | Int_Base.Value size when is_bitfield lv ~sizelv ~sizebf () -> + cast_lval_bitfield lv size v + | _ -> v + +and eval_lval_using_main_memory ~conflate_bottom ~with_alarms deps state lv = + let state,deps,loc = + lval_to_loc_deps_option ~with_alarms ?deps state lv + ~reduce_valid_index:(Kernel.SafeArrays.get ()) + in + CilE.set_syntactic_context (CilE.SyMem lv); + let result = + Cvalue.Model.find ~conflate_bottom ~with_alarms state loc + in +( Format.printf "lval %a before %a@." + !d_lval lv + Cvalue.V.pretty result; ) + let result = cast_lval_when_bitfield lv ~sizebf:loc.Locations.size result in +( Format.printf "lval %a after %a@." + !d_lval lv + Cvalue.V.pretty result; ) + ( TODO: move into Model.find ) + let valid_loc = Locations.valid_part ~for_writing:false loc in + let state = + if Location_Bits.equal loc.Locations.loc valid_loc.Locations.loc + then state + else begin + match lv with + Mem (exp_mem),NoOffset -> + let lv_mem_plus_list = + find_lv_plus ~with_alarms:CilE.warn_none_mode state exp_mem + in + let treat_lv_mem_plus (lv_mem, plus) state = + let loc_mem = + lval_to_loc ~with_alarms:CilE.warn_none_mode state lv_mem + in + if Location_Bits.is_relationable loc_mem.Locations.loc + then + let new_val = + Location_Bytes.location_shift + (Ival.neg plus) + (loc_bits_to_loc_bytes valid_loc.loc) + in + Cvalue.Model.reduce_binding + ~with_alarms:CilE.warn_none_mode + state loc_mem new_val + else state + in + List.fold_right treat_lv_mem_plus lv_mem_plus_list state + | _ -> state + end + in + (match with_alarms.CilE.imprecision_tracing with + | CilE.Aignore -> () + | CilE.Acall f -> f () + | CilE.Alog _ -> warn_lval_read lv loc result); + let new_deps = + match deps with + | None -> None + | Some deps -> + Some (Zone.join deps (valid_enumerate_bits ~for_writing:false loc)) + in + state, new_deps, result + +and eval_lval ~conflate_bottom ~with_alarms deps state lv = + let state, deps, result = + eval_lval_using_main_memory ~conflate_bottom ~with_alarms deps state lv + in + let result_conv = + ( match unrollType (Cil.typeOfLval lv) with + TFloat (FDouble|FFloat as kind, _) -> + let f, r = Cvalue.V.force_float kind result in + if f then Format.printf "TODO: assert@."; + r + | _ -> ) result + in + state, deps, result_conv + +and eval_offset ~reduce_valid_index ~with_alarms deps typ state offset = + match offset with + | NoOffset -> + state, deps, Ival.singleton_zero + | Index (exp,remaining) -> + let typ_pointed,array_size = match (unrollType typ) with + | TArray (t,size,_,_) -> t, size + | TPtr(t,_) -> + (match unrollType t with + | TArray (t,size,_,_) -> t,size ( pointer to start of an array ) + | _ -> + Value_parameters.error ~current:true + "Got type '%a'" !Ast_printer.d_type t; + assert false) + | t -> + Value_parameters.error ~current:true + "Got type '%a'" !Ast_printer.d_type t; + assert false + in + let state, deps, current = + eval_expr_with_deps_state ~with_alarms deps state exp + in + if V.is_bottom current + then Cvalue.Model.bottom, (Some Zone.bottom), Ival.bottom + else + let state, offset = + try + let v = V.project_ival current in + let state, v = + if reduce_valid_index then + try + let array_siz = lenOfArray64 array_size in + let new_v = + Ival.narrow + (Ival.inject_range + (Some Int.zero) + (Some (My_bigint.pred array_siz))) + v + in + let new_state = + if Ival.equal new_v v + then state + else begin + begin + match with_alarms.CilE.others with + | CilE.Aignore -> () + | CilE.Acall f -> f () + | CilE.Alog _ -> + CilE.set_syntactic_context + (CilE.SyBinOp + (IndexPI, + exp, + Cilutil.out_some array_size)); + CilE.warn_index with_alarms "accessing" + (Pretty_utils.sfprintf "%a" V.pretty current); + end; + state ( TODO : if the index is a variable, reduce ) + end + in + new_state, new_v + with LenOfArray -> state, v + else state, v + in + state, v + with V.Not_based_on_null -> + let deps, offset = + topify_offset + ~with_alarms + deps + state + (Cvalue.V.topify_arith_origin current) + remaining + in + raise (Offset_not_based_on_Null (deps,offset)) + in + let state, deps, r = + eval_offset ~reduce_valid_index ~with_alarms + deps typ_pointed state remaining + in + let offset = Ival.scale_int64base (sizeof typ_pointed) offset in + state, deps, Ival.add offset r + | Field (fi,remaining) -> + let current,_ = bitsOffset typ (Field(fi,NoOffset)) in + let state, deps, r = + eval_offset ~reduce_valid_index ~with_alarms + deps + fi.ftype + state + remaining + in + state, deps, Ival.add (Ival.of_int current) r +and topify_offset ~with_alarms deps state acc offset = + match offset with + | NoOffset -> deps,acc + | Field (_fi,remaining) -> topify_offset ~with_alarms deps state acc remaining + | Index (exp,remaining) -> + let deps, loc_index = eval_expr_with_deps ~with_alarms deps state exp in + let acc = Location_Bytes.join + (Cvalue.V.topify_arith_origin loc_index) + acc + in + topify_offset ~with_alarms deps state acc remaining + + +let eval_as_exact_loc ~with_alarms state e = + try + let lv = find_lv ~with_alarms state e in + let loc = lval_to_loc ~with_alarms state lv in + if not (valid_cardinal_zero_or_one ~for_writing:false loc) + then raise Not_an_exact_loc; + let typ = typeOfLval lv in + let value_for_loc = + Cvalue.Model.find ~conflate_bottom:true ~with_alarms state loc in + ( Using (typeOf e) caused imprecisions with the condition + char c; ... if (c>0) being transformed in if (((int)c)>0) by Cil. *) + let value_for_loc2 = do_cast ~with_alarms typ value_for_loc in + let value_for_loc2 = + cast_lval_when_bitfield lv ~sizebf:loc.size value_for_loc2 + in + if Cvalue.V.has_sign_problems value_for_loc && + not (Cvalue.V.equal value_for_loc value_for_loc2) + then raise Not_an_exact_loc; + loc, value_for_loc2, typ + with Cannot_find_lv -> + raise Not_an_exact_loc + +let eval_symetric_int positive binop cond_expr value = + match positive,binop with + | false, Eq | true, Ne -> V.diff_if_one value cond_expr + | true, Eq | false, Ne -> V.narrow value cond_expr + | _,_ -> value + +let eval_symetric_float = eval_symetric_int + +let eval_antisymetric_int ~typ_loc:_ positive binop cond_expr value = + try match positive,binop with + | true, Le | false, Gt -> V.filter_le value ~cond_expr + | true, Ge | false, Lt -> V.filter_ge value ~cond_expr + | false, Le | true, Gt -> V.filter_gt value ~cond_expr + | false, Ge | true, Lt -> V.filter_lt value ~cond_expr + | _,_ -> value + with V.Error_Bottom -> V.bottom + +let eval_antisymetric_float round ~typ_loc positive binop cond_expr value = + try let r = match positive,binop with + | true, Le | false, Gt -> V.filter_le_float round ~typ_loc value ~cond_expr + | true, Ge | false, Lt -> V.filter_ge_float round ~typ_loc value ~cond_expr + | false, Le | true, Gt -> V.filter_gt_float round ~typ_loc value ~cond_expr + | false, Ge | true, Lt -> V.filter_lt_float round ~typ_loc value ~cond_expr + | _,_ -> value + in + r + with V.Error_Bottom -> V.bottom + + +type eval_int_float = { + eval_symetric: bool -> binop -> V.t -> V.t -> V.t; + eval_antisymetric: typ_loc:typ -> bool -> binop -> V.t -> V.t -> V.t; +} + +let eval_int = { + eval_symetric = eval_symetric_int; + eval_antisymetric = eval_antisymetric_int; +} + +let eval_float round = { + eval_symetric = eval_symetric_float; + eval_antisymetric = eval_antisymetric_float round; +} + +let eval_from_type t round = + if isIntegralType t || isPointerType t + then eval_int + else eval_float round + +(** Reduce the state for comparisons of the form 'v Rel k', where v + evaluates to a location, and k to some value ) +let reduce_by_left_comparison ~with_alarms eval pos expl binop expr state = + try + let loc,value_for_loc,typ_loc = eval_as_exact_loc ~with_alarms state expl in +( Format.printf "red_by_left1 %a %a %a@." + Locations.pretty loc + Cvalue.V.pretty value_for_loc + !d_type typ_loc; ) + let cond_v = eval_expr ~with_alarms state expr in + let v_sym = eval.eval_symetric pos binop cond_v value_for_loc in + let v_asym = eval.eval_antisymetric ~typ_loc pos binop cond_v v_sym in +( Format.printf "red_by_left %a@." Cvalue.V.pretty v_asym; *) + if V.equal v_asym V.bottom then raise Reduce_to_bottom; + if V.equal v_asym value_for_loc + then state, Some loc + else + ( Cvalue.Model.reduce_binding + ~with_alarms:CilE.warn_none_mode + state loc v_asym, + Some loc ) + with Not_an_exact_loc -> state, None + +(** Reduce the state for comparisons of the form + 'v Rel k', 'k Rel v' or 'v = w' ) +let reduce_by_comparison ~with_alarms eval pos exp1 binop exp2 state = +( Format.printf "red_by %a@." Cvalue.Model.pretty state; ) + let state, _loc1 = reduce_by_left_comparison ~with_alarms eval + pos exp1 binop exp2 state + in + let inv_binop = match binop with + | Gt -> Lt | Lt -> Gt | Le -> Ge | Ge -> Le + | _ -> binop + in + let state, _loc2 = reduce_by_left_comparison ~with_alarms eval + pos exp2 inv_binop exp1 state + in +( Format.printf "red_by1 %a@." Cvalue.Model.pretty state; ) + ( Without relations, this is now the identity + begin match (pos, binop), loc1, loc2 with + | ((true, Eq) | (false, Ne)), Some left_loc , Some right_loc -> + Cvalue.Model.reduce_equality state left_loc right_loc + | _ -> state + end + *) + state + +(** raises [Reduce_to_bottom] and never returns [Cvalue.Model.bottom]) +let reduce_by_cond ~with_alarms state cond = + ( Do not reduce anything if the cond is volatile. + (This test is dumb because the cond may contain volatile l-values + without the "volatile" attribute appearing at toplevel. pc 2007/11) ) +( Format.printf "eval_cond %B %a@." cond.positive (!d_exp) cond.exp; ) + if hasAttribute "volatile" (typeAttr (typeOf cond.exp)) then state + else + let rec aux cond state = + match cond.positive,cond.exp.enode with + | _positive, BinOp ((Le|Ne|Eq|Gt|Lt|Ge as binop), exp1, exp2, _typ) -> + let eval = eval_from_type (unrollType (typeOf exp1)) + (Value_parameters.AllRoundingModes.get ()) + in + reduce_by_comparison ~with_alarms eval + cond.positive exp1 binop exp2 state + + | true, BinOp (LAnd, exp1, exp2, _) + | false, BinOp (LOr, exp1, exp2, _) -> + let new_state = aux {cond with exp = exp1} state in + let result = aux {cond with exp = exp2} new_state in + result + | false, BinOp (LAnd, exp1, exp2, _) + | true, BinOp (LOr, exp1, exp2, _) -> + let new_v1 = try aux {cond with exp = exp1} state + with Reduce_to_bottom -> Cvalue.Model.bottom + in let new_v2 = try aux {cond with exp = exp2} state + with Reduce_to_bottom -> Cvalue.Model.bottom + in let r = Cvalue.Model.join new_v1 new_v2 in + if Db.Value.is_reachable r then r else raise Reduce_to_bottom + + | _, UnOp(LNot,exp,_) -> + aux { positive = not cond.positive; exp = exp; } state + | _, Lval _ when (let t = typeOf cond.exp in + isIntegralType t || isPointerType t) + -> ( "if (c)" is equivalent to "if(!(c==0))" ) + (try + let loc,value_for_loc,_ = + eval_as_exact_loc ~with_alarms state cond.exp in + let new_value = eval_symetric_int + (not cond.positive) Eq V.singleton_zero value_for_loc + in + if V.equal new_value V.bottom then raise Reduce_to_bottom + else + Cvalue.Model.reduce_binding + ~with_alarms:CilE.warn_none_mode state loc new_value + with Not_an_exact_loc -> state) + | _ -> state + in + let result = aux cond state in + let contains_zero = + if Value_parameters.UndefinedPointerComparisonPropagateAll.get() + then V.contains_zero + else (fun x -> V.is_included V.singleton_zero x) + in + let condition_may_still_be_true_in_state state = + let cond_interp = eval_expr ~with_alarms state cond.exp in + (not cond.positive || V.contains_non_zero cond_interp) && + (cond.positive || contains_zero cond_interp) + in + if (not (Cvalue.Model.equal result state)) && + (not (condition_may_still_be_true_in_state result)) + then raise Reduce_to_bottom; + let is_enumerable v = + let v_interp = + Cvalue.Model.find ~conflate_bottom:true ~with_alarms result v + in + ignore (Location_Bytes.cardinal_less_than v_interp 7); + v_interp + in + let rec enumerate_one_var l = + match l with + | [] -> raise Not_found + | v::t -> + try + let v_interp = is_enumerable v in + v,v_interp,t + with Abstract_interp.Not_less_than -> + enumerate_one_var t + in + let invert_cond vl = + try + let v1,v_interp1, _tail = enumerate_one_var vl in +( Format.printf "enumerate %a %a@." + Locations.pretty v1 + Cvalue.V.pretty v_interp1; ) + let f one_val acc = + ( interpret cond in an environment where v -> one_val + ) + let env = + Cvalue.Model.reduce_binding + ~with_alarms:CilE.warn_none_mode + result v1 one_val + in + let stays = condition_may_still_be_true_in_state env in +( Format.printf "enumerate %a stays:%B@." + Cvalue.V.pretty one_val + stays; ) + if stays + then begin + Location_Bytes.join one_val acc + end + else begin + acc + end + in + let new_v_interp = + Location_Bytes.fold_enum + ~split_non_enumerable:2 + f v_interp1 Location_Bytes.bottom + in + let state_value = + if V.equal new_v_interp V.bottom + then raise Reduce_to_bottom + else + Cvalue.Model.reduce_binding + ~with_alarms:CilE.warn_none_mode + result v1 new_v_interp + in + state_value + with Not_found -> result + in + let result = + invert_cond (get_influential_vars ~with_alarms result cond.exp) + in + if not (Cvalue.Model.is_reachable result) + then raise Reduce_to_bottom + else result + + +let resolv_func_vinfo ~with_alarms deps state funcexp = + match funcexp.enode with + | Lval (Var vinfo,NoOffset) -> + Kernel_function.Hptset.singleton (Globals.Functions.get vinfo), deps + | Lval (Mem v,NoOffset) -> + let deps, loc = eval_expr_with_deps ~with_alarms deps state v in + let fundecs = List.fold_left + (fun acc varid -> + match varid with + | Base.String (_,_) -> + warning_once_current + "Function pointer call at string position in memory: \ + ignoring this particular value: assert(TODO)"; + acc + | Base.Null -> + warning_once_current + "Function pointer call at absolute position in memory: \ + ignoring this particular value: assert(TODO)"; + acc + | Base.Var (v,_) | Base.Initialized_Var (v,_) -> + Kernel_function.Hptset.add (Globals.Functions.get v) acc + ) + Kernel_function.Hptset.empty + (try Location_Bytes.get_keys_exclusive Ival.zero loc + with Location_Bytes.Not_all_keys -> + warning_once_current + "Function pointer call is completely unknown: \ + assuming no effects: assert(TODO)"; + raise Leaf) + in + fundecs, deps + | _ -> + assert false + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval_exprs.mli frama-c-20111001+nitrogen+dfsg/src/value/eval_exprs.mli --- frama-c-20110201+carbon+dfsg/src/value/eval_exprs.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval_exprs.mli 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,197 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types +open Locations + +exception Reduce_to_bottom +exception Cannot_find_lv +exception Too_linear +exception Leaf + +type cond = { exp : exp; positive : bool; } + +val check_comparable : + binop -> + Location_Bytes.t -> + Location_Bytes.t -> + bool * Location_Bytes.t * Location_Bytes.t + +val do_cast : + with_alarms:CilE.warn_mode -> typ -> Cvalue.V.t -> Cvalue.V.t + + +val eval_binop_float : + with_alarms:CilE.warn_mode -> + Cvalue.V.t -> binop -> Cvalue.V.t -> Cvalue.V.t +val eval_binop_int : + with_alarms:CilE.warn_mode -> + ?typ:typ -> + te1:typ -> + Cvalue.V.t -> binop -> Cvalue.V.t -> Cvalue.V.t + +val eval_unop: + with_alarms:CilE.warn_mode -> + Cvalue.V.t -> + typ (** Type of the expression under the unop ) -> + Cil_types.unop -> Cvalue.V.t + + +val is_bitfield : + lval -> ?sizelv:Int_Base.t -> ?sizebf:Int_Base.t -> unit -> bool + +val lval_to_loc : + with_alarms:CilE.warn_mode -> + Cvalue.Model.t -> lval -> location +val exp_lval_to_loc : + Cvalue.Model.t -> exp -> lval location +val lval_to_loc_deps_option : + with_alarms:CilE.warn_mode -> + deps:Zone.t option -> + Cvalue.Model.t -> + reduce_valid_index:Kernel.SafeArrays.t -> + lval -> + Cvalue.Model.t * Zone.t option * location +val lval_to_loc_with_offset_deps_only : + deps:Zone.t -> + Cvalue.Model.t -> + lval -> + with_alarms:CilE.warn_mode -> + Cvalue.Model.t * Zone.t option * location +val lval_to_loc_with_deps : + deps:Zone.t -> + Cvalue.Model.t -> + lval -> + with_alarms:CilE.warn_mode -> + reduce_valid_index:Kernel.SafeArrays.t -> + Cvalue.Model.t * Zone.t option * location +val lval_to_loc_with_offset_deps_only_option : + with_alarms:CilE.warn_mode -> + deps:Zone.t option -> + Cvalue.Model.t -> + lval -> + Cvalue.Model.t * Zone.t option * location +val pass_cast : + with_alarms:CilE.warn_mode -> + Cvalue.Model.t -> exn -> typ -> exp -> unit +val find_lv : + with_alarms:CilE.warn_mode -> + Cvalue.Model.t -> exp -> lval +val find_lv_plus : + with_alarms:CilE.warn_mode -> + Cvalue.Model.t -> exp -> (lval * Ival.t) list +val base_to_loc : + with_alarms:CilE.warn_mode -> + ?deps:Zone.t -> + Cvalue.Model.t -> + lval -> + lhost -> + Ival.t -> Cvalue.Model.t * Zone.t option * location +val eval_expr : + with_alarms:CilE.warn_mode -> Cvalue.Model.t -> exp -> Cvalue.V.t +val get_influential_vars : + with_alarms:CilE.warn_mode -> + Cvalue.Model.t -> exp -> location list +val reduce_by_valid_expr : + positive:bool -> + for_writing:bool -> exp -> Cvalue.Model.t -> Cvalue.Model.t +val reduce_by_valid_loc : + positive:bool -> + for_writing:bool -> location -> typ -> Cvalue.Model.t -> Cvalue.Model.t +val reduce_by_initialized_loc : + with_alarms:'a -> + positive:bool -> + typ * Location_Bytes.t -> + Cvalue.Model.t -> Cvalue.Model.t +val eval_BinOp : + with_alarms:CilE.warn_mode -> + exp -> + Zone.t option -> + Cvalue.Model.t -> Cvalue.Model.t * Zone.t option * Cvalue.V.t +val eval_expr_with_deps : + with_alarms:CilE.warn_mode -> + Zone.t option -> + Cvalue.Model.t -> exp -> Zone.t option * Cvalue.V.t +val eval_expr_with_deps_state : + with_alarms:CilE.warn_mode -> + Zone.t option -> + Cvalue.Model.t -> + exp -> + Cvalue.Model.t * Zone.t option * Location_Bytes.t +val eval_expr_with_deps_state_subdiv : + with_alarms:CilE.warn_mode -> + Zone.t option -> + Cvalue.Model.t -> + exp -> + Cvalue.Model.t * Zone.t option * Location_Bytes.t +val cast_lval_bitfield : + lval -> Abstract_interp.Int.t -> Cvalue.V.t -> Cvalue.V.t +val cast_lval_when_bitfield : + lval -> + ?sizelv:Int_Base.t -> ?sizebf:Int_Base.t -> Cvalue.V.t -> Cvalue.V.t +val eval_lval_using_main_memory : + conflate_bottom:bool -> + with_alarms:CilE.warn_mode -> + Zone.t option -> + Cvalue.Model.t -> + lval -> Cvalue.Model.t * Zone.t option * Cvalue.V.t +val eval_lval : + conflate_bottom:bool -> + with_alarms:CilE.warn_mode -> + Zone.t option -> + Cvalue.Model.t -> + lval -> Cvalue.Model.t * Zone.t option * Cvalue.V.t +val eval_offset : + reduce_valid_index:bool -> + with_alarms:CilE.warn_mode -> + Zone.t option -> + typ -> + Cvalue.Model.t -> + offset -> Cvalue.Model.t * Zone.t option * Ival.t +val eval_as_exact_loc : + with_alarms:CilE.warn_mode -> + Cvalue.Model.t -> + exp -> location * Cvalue.V.t * typ +type eval_int_float = { + eval_symetric : + bool -> binop -> Cvalue.V.t -> Cvalue.V.t -> Cvalue.V.t; + eval_antisymetric : + typ_loc:typ -> + bool -> binop -> Cvalue.V.t -> Cvalue.V.t -> Cvalue.V.t; +} +val eval_int : eval_int_float +val eval_float : bool -> eval_int_float +val eval_from_type : typ -> bool -> eval_int_float +val reduce_by_comparison : + with_alarms:CilE.warn_mode -> + eval_int_float -> + bool -> + exp -> + binop -> exp -> Cvalue.Model.t -> Cvalue.Model.t +val reduce_by_cond : + with_alarms:CilE.warn_mode -> Cvalue.Model.t -> cond -> Cvalue.Model.t +val resolv_func_vinfo : + with_alarms:CilE.warn_mode -> + Zone.t option -> + Cvalue.Model.t -> + exp -> Kernel_function.Hptset.t * Zone.t option + diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval_funs.ml frama-c-20111001+nitrogen+dfsg/src/value/eval_funs.ml --- frama-c-20110201+carbon+dfsg/src/value/eval_funs.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval_funs.ml 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,583 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Value analysis of statements ) + +open Cil_types +open Cil +open Cil_datatype +open Locations +open Abstract_interp +open Bit_utils +open Cvalue +open Value_util +open Eval_exprs +open Locals_scoping + +module StmtCanReachCache = + Kernel_function.Make_Table + (Datatype.Function + (struct include Cil_datatype.Stmt let label = None end) + (Datatype.Function + (struct include Cil_datatype.Stmt let label = None end) + (Datatype.Bool))) + (struct + let name = "Eval_funs.StmtCanReachCache" + let kind = `Internal + let size = 17 + let dependencies = [ Ast.self ] + end) + +let stmt_can_reach_memo = StmtCanReachCache.memo Stmts_graph.stmt_can_reach + +let compute_using_cfg kf ~call_kinstr initial_state = + match kf.fundec with + | Declaration _ -> assert false + | Definition (f,_loc) -> + begin + let f_varinfo = f.svar in + let module Computer = + Eval_stmts.Computer + (struct + let current_kf = kf + let stmt_can_reach = + if Value_parameters.MemoryFootprint.get () >= 3 + then stmt_can_reach_memo kf + else Stmts_graph.stmt_can_reach kf + let is_natural_loop = Loop.is_natural kf + let non_linear_assignments = Non_linear.find f + let slevel = get_slevel kf + let initial_state = initial_state ( for future reference ) + let active_behaviors = + Eval_logic.ActiveBehaviors.create initial_state kf + end) + in + let module Compute = Dataflow.Forwards(Computer) in + List.iter + (function {called_kf = g} -> + if kf == g + then begin + if Value_parameters.IgnoreRecursiveCalls.get() + then begin + warning_once_current + "ignoring recursive call during value analysis of %a (%a)" + Varinfo.pretty f_varinfo + pretty_call_stack (call_stack ()); + Db.Value.recursive_call_occurred kf; + raise Leaf + end + else begin + warning_once_current + "@[recursive call@ during@ value@ analysis@ (%a <- %a)@.Use %s@ to@ ignore@ (beware@ this@ will@ make@ the analysis@ unsound)@]" + Varinfo.pretty f_varinfo + pretty_call_stack (call_stack ()) + Value_parameters.IgnoreRecursiveCalls.option_name; + raise (Extlib.NotYetImplemented "recursive calls in value analysis") + end + end) + (call_stack ()); + push_call_stack {called_kf = kf; + call_site = call_kinstr; + called_merge_current = Computer.merge_current}; + match f.sbody.bstmts with + [] -> assert false + | start :: _ -> + let ret_id = + try Kernel_function.find_return kf + with Kernel_function.No_Statement -> assert false + in + ( We start with only the start block ) + Computer.StmtStartData.add + start + (Computer.computeFirstPredecessor + start + { + Computer.counter_unroll = 0; + value = initial_state}); + begin try + Compute.compute [start] + with Db.Value.Aborted as e -> + ( State_builder.was aborted: pop the call stack and inform + the caller ) + pop_call_stack (); + raise e + end; + let last_ret,_,last_clob as last_state = + try + let _,state,_ as result = + try + Computer.externalize ret_id kf + with Not_found -> assert false + in + if Cvalue.Model.is_reachable state + then begin + try + if hasAttribute "noreturn" f_varinfo.vattr + then + warning_once_current + "function %a may terminate but has the noreturn attribute" + Kernel_function.pretty kf; + with Not_found -> assert false + end + else raise Not_found; + result + with Not_found -> begin + None, + Cvalue.Model.bottom, + Location_Bits.Top_Param.bottom + end + in + Value_parameters.debug + "@[RESULT FOR %a <-%a:@\n\\result -> %a@\nClobered set:%a@]" + Kernel_function.pretty kf + pretty_call_stack (call_stack ()) + (fun fmt v -> + match v with + | None -> () + | Some v -> V_Offsetmap.pretty fmt v) + last_ret + Location_Bits.Top_Param.pretty + last_clob; + pop_call_stack (); + last_state + end + +let compute_using_prototype kf ~active_behaviors ~state_with_formals = +( Format.printf "compute_using_prototype %s %a@." + (Kernel_function.get_name kf) + Cvalue.Model.pretty state_with_formals; ) + let vi = Kernel_function.get_vi kf in + if Cil.hasAttribute "noreturn" vi.vattr then + None, Cvalue.Model.bottom, Location_Bits.Top_Param.bottom + else + let return_type,_formals_type,_inline,_attr = + splitFunctionType (Kernel_function.get_type kf) + in + let behaviors = + Eval_logic.ActiveBehaviors.active_behaviors active_behaviors in + let assigns = Ast_info.merge_assigns behaviors in + let returned_value, state_with_formals = + Library_functions.returned_value kf return_type state_with_formals + in + let returned_value = ref returned_value in + let clobbered_set = ref Location_Bits.Top_Param.bottom in + let state = + match assigns with + | WritesAny -> + warning_once_current "Cannot handle empty assigns clause. Assuming assigns \\nothing: be aware this is probably incorrect."; + state_with_formals + | Writes [] -> state_with_formals + | Writes l -> + let treat_assign acc (out, ins) = + let input_contents = + try + match ins with + | FromAny -> Cvalue.V.top_int + | From l -> + List.fold_left + (fun acc term -> + let input_loc = + !Db.Properties.Interp.loc_to_loc + ~result:None + state_with_formals + term.it_content + in + let r = + Cvalue.V.topify_arith_origin( + Cvalue.Model.find + ~conflate_bottom:true + ~with_alarms:CilE.warn_none_mode + state_with_formals + input_loc + ) in + Cvalue.V.join acc r) + Cvalue.V.top_int + l + with Invalid_argument "not an lvalue" -> + warning_once_current + "cannot interpret@ assigns@ in function %a" + Kernel_function.pretty kf; + Cvalue.V.top + in + let treat_output_loc loc acc = + remember_bases_with_locals + clobbered_set + loc + input_contents; + let state = + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:false acc loc input_contents + in + ( ugly; Fix ? Yes. ) + if Cvalue.Model.is_reachable state + then state + else acc + in + try + let loc = !Db.Properties.Interp.loc_to_loc + ~result:None acc out.it_content + in + let st = treat_output_loc loc acc in + if Cvalue.Model.equal Cvalue.Model.top st then ( + Value_parameters.error ~once:true ~current:true + "Cannot@ handle@ assigns@ for %a,@ location@ is@ too@ \ + imprecise@ (%a).@ Assuming@ it@ is@ not@ assigned,@ but@ \ + be@ aware@ this@ is@ incorrect." + d_term out.it_content Locations.pretty loc; + acc) + else st + with + | Invalid_argument "not an lvalue" -> + if Logic_utils.is_result out.it_content then begin + returned_value := + Cvalue.V.join input_contents !returned_value; + acc + end else begin + warning_once_current + "Cannot interpret assigns in function %a; \ + effects will be ignored" + Kernel_function.pretty kf; acc + end + in + (List.fold_left treat_assign state_with_formals l) + in +( Value_parameters.debug "compute_using_prototype suite %s %a@." + (Kernel_function.get_name kf) + Cvalue.Model.pretty state; ) + let retres_vi, state = + if isVoidType return_type + then None, state + else + let offsetmap = + V_Offsetmap.update_ival + ~with_alarms:CilE.warn_none_mode + ~validity:Base.All + ~offsets:Ival.zero + ~exact:true + ~size:(Int.of_int (bitsSizeOf return_type)) + V_Offsetmap.empty + (Cvalue.V_Or_Uninitialized.initialized !returned_value) + in + let rvi, state = Library_functions.add_retres_to_state + ~with_alarms:CilE.warn_none_mode kf offsetmap state + in + Some rvi, state + in + retres_vi, state, !clobbered_set + +let initial_state_formals kf (state:Cvalue.Model.t) = + match kf.fundec with + | Declaration (_, _, None, _) -> state + | Declaration (_, _, Some l, _) + | Definition ({ sformals = l }, _) -> + List.fold_right + Initial_state.initialize_var_using_type + l + state + +let rec fold_left2_best_effort f acc l1 l2 = + match l1,l2 with + | _,[] -> acc + | [],_ -> + raise Eval_stmts.Wrong_function_type + | (x1::r1),(x2::r2) -> fold_left2_best_effort f (f acc x1 x2) r1 r2 + +let actualize_formals kf state actuals check = + let formals = Kernel_function.get_formals kf in + let treat_one_formal acc (expr,_actual_val,actual_o) formal = + check expr formal; + let loc_without_size = + Location_Bits.inject + (Base.create_varinfo formal) + (Ival.zero) + in + Cvalue.Model.paste_offsetmap CilE.warn_none_mode + actual_o + loc_without_size + Int.zero + (Int_Base.project (sizeof_vid formal)) + true + acc + in + fold_left2_best_effort + treat_one_formal + state + actuals + formals + +let () = + Db.Value.add_formals_to_state := + (fun state kf exps -> + try + let compute_actual = Eval_stmts.compute_actual + ~with_alarms:CilE.warn_none_mode (false, false) in + let actuals = List.map (compute_actual state) exps in + actualize_formals kf state actuals + (fun _ _ -> ()) + with Eval_stmts.Got_bottom -> Cvalue.Model.bottom) + +let compute_using_declaration kf with_formals = + Kf_state.mark_as_called kf; + let stateset = Eval_logic.check_fct_preconditions kf with_formals in + ( TODO: This is a hack. Use a function that checks preconditions without + multiplying the states instead -- or compute_using_prototype several times ) + let active_behaviors = Eval_logic.ActiveBehaviors.create stateset kf in + let state_with_formals = State_set.join stateset in + let retres_vi, result_state, thing = + compute_using_prototype kf ~active_behaviors ~state_with_formals in + let result_state = + Eval_logic.check_fct_postconditions ~result:retres_vi kf ~active_behaviors + ~init_state:(State_set.singleton state_with_formals) + ~post_state:(State_set.singleton result_state) + Normal + in + let result_state = State_set.join result_state in + let result, result_state = match retres_vi with + | None -> None, result_state + | Some vi -> + if not (Cvalue.Model.is_reachable result_state) then + ( This test prevents the call to Model.find_base that would + raise Not_found in this case. ) + None, result_state + else + let value_state = result_state in + let retres_base = Base.create_varinfo vi in + (Some (Cvalue.Model.find_base retres_base value_state)) , + Cvalue.Model.remove_base retres_base result_state + in + let formals = Kernel_function.get_formals kf in + let result_state = + List.fold_left + (fun acc vi -> + Cvalue.Model.remove_base + (Base.create_varinfo vi) + acc) + result_state + formals + in + result, result_state, thing + +( In the state [initial_state] globals and formals are present + but locals of [kf] are not.) +let compute_with_initial_state ~call_kinstr kf with_formals = + match kf.fundec with + | Declaration _ -> compute_using_declaration kf with_formals + | Definition (f,_) -> + let with_locals = + List.fold_left + (fun acc local -> + Cvalue.Model.add_binding_not_initialized + acc + (Locations.loc_of_varinfo local)) + with_formals + f.slocals + in + ( Remark: the pre-condition cannot talk about the locals. BUT + check_fct_preconditions split the state into a stateset, hence + it is simpler to apply it to the (unique) state with locals ) + let initial_states= Eval_logic.check_fct_preconditions kf with_locals in + compute_using_cfg ~call_kinstr kf initial_states + +let compute_entry_point kf ~library = + clear_call_stack (); + Kf_state.mark_as_called kf; + Value_parameters.feedback "Analyzing a%scomplete application starting at %a" + (if library then "n in" else " ") + Kernel_function.pretty kf; + + Separate.prologue(); + + let initial_state_globals = + if Db.Value.globals_use_supplied_state () then ( + let r = Db.Value.globals_state () in + Value_parameters.feedback "Initial state supplied by user"; + Value_parameters.debug "@[<hov 0>Values of globals@\n%a@]" + Db.Value.pretty_state_without_null r; + r) + else ( + Value_parameters.feedback "Computing initial state"; + let r = Db.Value.globals_state () in + Value_parameters.feedback "Initial state computed"; + Value_parameters.result + "@[<hov 0>Values of globals at initialization@\n%a@]" + Db.Value.pretty_state_without_null r; + r + ) in + if not (Db.Value.is_reachable initial_state_globals) then begin + Value_parameters.result "Value analysis not started because globals \ + initialization is not computable."; + None, initial_state_globals, Locations.Location_Bits.Top_Param.empty + end else begin + Mark_noresults.run(); + + let with_formals = match Db.Value.fun_get_args () with + | None -> initial_state_formals kf initial_state_globals + | Some actuals -> + let formals = Kernel_function.get_formals kf in + if (List.length formals) <> List.length actuals then + raise Db.Value.Incorrect_number_of_arguments; + let treat_one_formal f a = + (), a, Builtins.offsetmap_of_value ~typ:f.vtype a + in + actualize_formals + kf + initial_state_globals + (List.map2 treat_one_formal formals actuals) + (fun _ _ -> ()) + in + Db.Value.Call_Value_Callbacks.apply (with_formals, [ kf, Kglobal ]); + let result = + compute_with_initial_state kf ~call_kinstr:Kglobal with_formals + in + Value_parameters.feedback "done for function %a" + Kernel_function.pretty kf; + Separate.epilogue(); + result + end + +let compute_call_to_cil_function kf _initial_state with_formals call_kinstr = + let print_progress = Value_parameters.ValShowProgress.get() in + if print_progress then + Value_parameters.feedback + "@[computing for function %a <- %a.@\nCalled from %a.@]" + Kernel_function.pretty kf + pretty_call_stack (call_stack ()) + pretty_loc_simply (CilE.current_stmt()); + let result = match kf.fundec with + | Declaration (_,_,_,_) -> + compute_using_declaration kf with_formals + | Definition (def, _) -> + Kf_state.mark_as_called kf; + if Datatype.String.Set.mem + def.svar.vname (Value_parameters.UsePrototype.get ()) + then + compute_using_declaration kf with_formals + else + compute_with_initial_state kf ~call_kinstr with_formals + in + if print_progress then + Value_parameters.feedback "Done for function %a" + Kernel_function.pretty kf; + result + +( Compute a call to a possible builtin. Returns [Some result], or [None] + if the call must be computed using the Cil function ) +let compute_call_to_builtin kf initial_state actuals = + let name = Kernel_function.get_name kf in + try + let name, override = + ( Advanced builtins which override a Cil function with a Caml one, but + use the Cil one as backup if the Caml one fails. (None by default) ) + try + let name = Value_parameters.BuiltinsOverrides.find name in + Kf_state.mark_as_called kf; + name, true + with Not_found -> name, false + in + ( Standard builtins with constant names, e.g. Frama_C_cos ) + let abstract_function = Builtins.find_builtin name in + (try + Some (abstract_function initial_state actuals) + with Db.Value.Outside_builtin_possibilities -> + if override then None + else ( + do_degenerate None; + raise Db.Value.Aborted + ) + ) + with Not_found -> + ( Special builtins, such as Frama_C_show_each_foo ) + if Ast_info.can_be_cea_function name then + ( A few special functions that are not registered in the builtin table ) + if Ast_info.is_cea_dump_function name then + Some (Builtins.dump_state initial_state) + else if Ast_info.is_cea_alloc_with_validity name then + Some (Builtins.alloc_with_validity initial_state actuals) + else if Ast_info.is_cea_function name then + Some (Builtins.dump_args name initial_state actuals) + else if Ast_info.is_cea_dump_file_function name then + Some (Builtins.dump_state_file name initial_state actuals) + else + None + else None + +let compute_call kf ~call_kinstr initial_state actuals = + let with_formals = + actualize_formals kf initial_state actuals + (fun expr formal -> + if bitsSizeOf (typeOf expr) <> bitsSizeOf (formal.vtype) + then raise Eval_stmts.Wrong_function_type) + in + Db.Value.merge_initial_state kf with_formals; + let stack_without_call = for_callbacks_stack () in + Db.Value.Call_Value_Callbacks.apply + (with_formals, ((kf, call_kinstr) :: stack_without_call)); + match compute_call_to_builtin kf initial_state actuals with + | Some r -> r + | None -> + compute_call_to_cil_function kf initial_state with_formals call_kinstr + +let () = Eval_stmts.compute_call_ref := compute_call + +let floats_ok () = + let u = min_float /. 2. in + let u = u /. 2. in + 0. < u && u < min_float + +let cleanup () = + StmtCanReachCache.clear () + +let force_compute () = + assert (floats_ok ()); + try + let kf, library = Globals.entry_point () in + ignore (compute_entry_point kf ~library); + Db.Value.mark_as_computed (); + cleanup (); + ( Remove redundant alarms ) + if Value_parameters.RmAssert.get() then !Db.Scope.rm_asserts () + with + | Db.Value.Aborted -> + cleanup (); + ( This case is reached only if [do_degenerate] did not raise another + exception to handle abortion properly. See the behavior of the GUI + in case of degeneration to understand the machinery. ) + Db.Value.mark_as_computed (); + Value_parameters.abort + "Degeneration occured:@\nresults are not correct for lines of code \ +that can be reached from the degeneration point." + | Globals.No_such_entry_point _ as exn -> raise exn + | exn -> Db.Value.mark_as_computed (); raise exn + +let _self = + Db.register_compute "Value.compute" + [ Db.Value.self ] + Db.Value.compute + (fun () -> if not (Db.Value.is_computed ()) then force_compute ()) + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval_funs.mli frama-c-20111001+nitrogen+dfsg/src/value/eval_funs.mli --- frama-c-20110201+carbon+dfsg/src/value/eval_funs.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval_funs.mli 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,27 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval_logic.ml frama-c-20111001+nitrogen+dfsg/src/value/eval_logic.ml --- frama-c-20110201+carbon+dfsg/src/value/eval_logic.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval_logic.ml 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,1061 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +open Cil_types +open Cil +open Cil_datatype +open Eval_exprs +open Locations +open Abstract_interp +open Cvalue +open Bit_utils +open Value_util + + +( Truth values for a predicate analyzed by the value analysis ) + +type predicate_value = True | False | Unknown + +let string_of_predicate_value = function + | Unknown -> "unknown" + | True -> "valid" + | False -> "invalid" + +let pretty_predicate_value fmt v = + Format.fprintf fmt "%s" (string_of_predicate_value v) + +let join_predicate x y = match x, y with + | True, True -> True + | False, False -> False + | True, False | False, True + | Unknown, _ | _, Unknown -> Unknown + +exception Stop + +let fold_join_predicate fold f s = + try + match + fold + (fun acc e -> + match f e with + | Unknown -> raise Stop + | v -> match acc with + | None -> Some v + | Some acc -> Some (join_predicate acc v) + ) + None + s + with + | None -> True + | Some v -> v + with Stop -> Unknown + +( Exception raised to end the computation for a predicate *) +exception Predicate_alarm +let predicate_alarm () = raise Predicate_alarm + +let warn_raise_mode = + { CilE.imprecision_tracing = CilE.Aignore ; + others = CilE.Acall predicate_alarm ; + unspecified = CilE.Acall predicate_alarm } + + +(** Evaluation environments. Used to evaluate predicate on \at nodes ) + +( Labels: + pre: pre-state of the function. Equivalent to \old in the postcondition + (and displayed as such) + here: current location, always the intuitive meaning. Assertions are + evaluated before the statement. + post: forbidden in preconditions; + In postconditions: + in function contracts, state of in the post-state + in statement contracts, state after the evaluation of the statement + old: forbidden in assertions. + In statement contracts post, means the state before the statement + In functions contracts post, means the pre-state +) + +type label = Pre | Here | Old | Post + +type eval_env = { + e_cur: label; + e_pre: Cvalue.Model.t; + e_here: Cvalue.Model.t; + e_old: Cvalue.Model.t option; + e_post: Cvalue.Model.t option; +} + +let join_env e1 e2 = + let join_opt v1 v2 = match v1, v2 with + | None, None -> None + | Some v, None | None, Some v -> Some v + | Some v1, Some v2 -> Some (Cvalue.Model.join v1 v2) + in { + e_cur = (assert (e1.e_cur = e2.e_cur); e1.e_cur); + e_pre = Cvalue.Model.join e1.e_pre e2.e_pre; + e_here = Cvalue.Model.join e1.e_here e2.e_here; + e_old = join_opt e1.e_old e2.e_old; + e_post = join_opt e1.e_post e2.e_post; + } + +let extract_opt_env = function + | Some v -> v + | None -> predicate_alarm () + +let convert_label = function + | StmtLabel _ -> predicate_alarm () + | LogicLabel (_, "Pre") -> Pre + | LogicLabel (_, "Here") -> Here + | LogicLabel (_, "Old") -> Old + | LogicLabel (_, "Post") -> Post + | LogicLabel _ -> predicate_alarm () + +let env_state env = function + | Pre -> env.e_pre + | Here -> env.e_here + | Old -> extract_opt_env env.e_old + | Post -> extract_opt_env env.e_post + +let env_current_state e = env_state e e.e_cur + +let overwrite_state env state = function + | Pre -> { env with e_pre = state } + | Here -> { env with e_here = state } + | Old -> { env with e_old = Some state } + | Post -> { env with e_post = Some state } + +let overwrite_current_state env state = overwrite_state env state env.e_cur + +let env_pre_f ~init = { + e_cur = Here; + e_pre = init; e_here = init; + e_post = None; e_old = None; +} + +let env_post_f ~pre ~post = { + e_cur = Here; + e_pre = pre; e_old = Some pre; + e_post = Some post; e_here = post; +} + +let env_annot ~pre ~here = { + e_cur = Here; + e_pre = pre; e_here = here; + e_post = None; e_old = None; +} + + +let (!!) = Lazy.force + +let lop_to_cop op = + match op with + | Req -> Eq + | Rneq -> Ne + | Rle -> Le + | Rge -> Ge + | Rlt -> Lt + | Rgt -> Gt + +let rec eval_term env result t = + let with_alarms = warn_raise_mode in + match t.term_node with + | Tat (t, lab) -> begin + let lab = convert_label lab in + eval_term { env with e_cur = lab } result t + end + + | TConst (CInt64 (v, _, _)) -> [intType, Cvalue.V.inject_int v] + | TConst (CEnum e) -> + (match (constFold true e.eival).enode with + | Const (CInt64 (v, _, _)) -> [intType, Cvalue.V.inject_int v] + | _ -> raise Predicate_alarm) + | TConst (CChr c) -> [intType, Cvalue.V.inject_int + (Int.of_int (int_of_char c))] + | TConst (CReal (f, _, _)) -> + ( TODO: there might be a problem with float constant present in the + code that have been rounded ) + Value_parameters.result ~once:true "float support is experimental"; + let f = Ival.F.of_float f in + let _, f = Ival.Float_abstract.inject_r f f in + [floatType, Cvalue.V.inject_ival (Ival.Float f)] +( | TConst ((CStr | CWstr) Missing cases ) + + | TAddrOf _ + | TStartOf _ -> + let conv (typ, loc) = (typ, loc_bits_to_loc_bytes loc) in + List.map conv (eval_tlval env result t) + + | TLval _ -> + let lvals = eval_tlval env result t in + let eval_lval (typ, loc) = + let v = Cvalue.Model.find ~conflate_bottom:false + ~with_alarms (env_current_state env) + (make_loc loc (Bit_utils.sizeof typ)) + in + let v = do_cast ~with_alarms typ v in + (typ, v) + in + List.map eval_lval lvals + + | TBinOp (op,t1,t2) -> begin + let l1 = eval_term env result t1 in + let l2 = eval_term env result t2 in + let aux (te1, v1) (_te2, v2) = + ( Format.printf "T1 %a %a:%a, T2 %a %a:%a@." + d_term t1 Cvalue.V.pretty v1 d_type te1 + d_term t2 Cvalue.V.pretty v2 d_type _te2; ) + let te1 = unrollType te1 in + ( We use the type of t1 to determine whether we are performing + an int or float operation. Hopefully this is correct ) + let v = match te1 with + | TInt _ | TPtr _ | TEnum _ -> + ( Do not pass ~typ here. We want the operations to be + performed on unbounded integers mode ) + eval_binop_int ~with_alarms ~te1 v1 op v2 + | TFloat _ -> + eval_binop_float ~with_alarms v1 op v2 + | _ -> raise Predicate_alarm + in + (te1, v) + in + match op, l1, l2 with + | (PlusA | PlusPI | IndexPI | MinusA | MinusPI), _, _ + | (Eq | Ne), _ , _ -> ( TODO: use set semantics ) + List.fold_left (fun acc e1 -> + List.fold_left (fun acc e2 -> aux e1 e2 :: acc) acc l2) [] l1 + | _, [e1], [e2] -> [aux e1 e2] + | _ -> (Format.printf "Bla %a %a@." d_term t1 d_term t2;) + raise Predicate_alarm + end + + | TUnOp (op, t) -> + let l = eval_term env result t in + let typ' t = match op with + | Neg -> t + | BNot -> t ( can only be used on an integer type ) + | LNot -> intType + in + let eval typ v = eval_unop ~with_alarms v typ op in + List.map (fun (typ, v) -> typ' typ, eval typ v) l + + | Trange (otlow, othigh) -> + let eval proj join = function + | None -> None + | Some t -> + let lbound = eval_term env result t in + let aux (typ, v) = + if not (isIntegralType typ) then raise Predicate_alarm; + try proj (Cvalue.V.project_ival v) + with Cvalue.V.Not_based_on_null -> None + in + match List.map aux lbound with + | [] -> raise Predicate_alarm + | h :: q -> + let join v1 v2 = match v1, v2 with + | None, _ | _, None -> None + | Some v1, Some v2 -> Some (join v1 v2) + in + List.fold_left join h q + in + let min = eval Ival.min_int Int.min otlow + and max = eval Ival.max_int Int.max othigh in + [intType, Cvalue.V.inject_ival (Ival.inject_range min max)] + + | TCastE (typ, t) -> + let l = eval_term env result t in + List.map (fun (_, v) -> typ, do_cast ~with_alarms typ v) l + + | Tif (tcond, ttrue, tfalse) -> + let l = eval_term env result tcond in + let vtrue = List.exists (fun (_, v) -> Cvalue.V.contains_non_zero v) l + and vfalse = List.exists (fun (_, v) -> Cvalue.V.contains_zero v) l in + (if vtrue then eval_term env result ttrue else []) + @ (if vfalse then eval_term env result tfalse else []) + + | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ -> + let e = Cil.constFoldTerm true t in + let r = match e.term_node with + | TConst (CInt64 (v, _, _)) -> Cvalue.V.inject_int v + | _ -> V.top_int + in + [intType, r] + + | _ -> raise Predicate_alarm + +and eval_tlhost env result lv = + match lv with + | TVar { lv_origin = Some v } -> + let loc = Location_Bits.inject (Base.find v) Ival.zero in + [v.vtype, loc] + | TResult typ -> + (match result with + | Some v -> + let loc = Location_Bits.inject (Base.find v) Ival.zero in + [typ, loc] + | None -> raise Predicate_alarm) + | TVar { lv_origin = None } -> ( TODO: add an env for logic vars ) + raise Predicate_alarm + | TMem t -> + let l = eval_term env result t in + List.map (fun (t, loc) -> + match t with + | TPtr (t, _) -> t, loc_bytes_to_loc_bits loc + | _ -> raise Predicate_alarm + ) l + +and eval_toffset env result typ toffset = + match toffset with + | TNoOffset -> + [typ, Ival.singleton_zero] + | TIndex (trm, remaining) -> + let typ_pointed = match (unrollType typ) with + | TArray (t, _, _, _) -> t + | TPtr(t,_) -> + (match unrollType t with + | TArray (t, _,_,_) -> t + | _ -> raise Predicate_alarm) + | _ -> raise Predicate_alarm + in + let lloctrm = eval_term env result trm in + let aux (_typ, current) = + let offset = + try Cvalue.V.project_ival current + with Cvalue.V.Not_based_on_null -> raise Predicate_alarm + in + let loffsrem = eval_toffset env result typ_pointed remaining in + let aux (typ, r) = + let offset = Ival.scale_int64base (sizeof typ_pointed) offset in + typ, Ival.add offset r + in + List.map aux loffsrem + in + List.fold_left (fun acc trm -> aux trm @ acc) [] lloctrm + + | TField (fi,remaining) -> + let current,_ = bitsOffset typ (Field(fi,NoOffset)) in + let loffs = eval_toffset env result fi.ftype remaining in + List.map (fun (typ, r) -> typ, Ival.add (Ival.of_int current) r) loffs + +and eval_tlval env result t = + let process ftyp tlval toffs = + let lvals = eval_tlhost env result tlval in + let aux acc (typ, loc) = + let loffset = eval_toffset env result typ toffs in + let aux acc (typ_offs, offs) = + let loc = Location_Bits.location_shift offs loc in + (ftyp typ_offs, loc) :: acc + in + List.fold_left aux acc loffset + in + List.fold_left aux [] lvals + in + match t.term_node with + | TAddrOf (tlval, toffs) + | TStartOf (tlval, toffs) -> + process (fun typ -> TPtr (typ, [])) tlval toffs + | TLval (tlval, toffs) -> + process (fun typ -> typ) tlval toffs + | Tunion l -> List.concat (List.map (eval_tlval env result) l) + | Tempty_set -> [] + ( TODO: add support for TcastE, by adapting what is done for pass_cast + in eval_exprs.ml ) + | _ -> raise Predicate_alarm + +let eval_tlval_as_location env result t = + let l = eval_tlval env result t in + let aux acc (typ, loc) = + let s = Bit_utils.sizeof typ in + assert (loc_equal acc loc_bottom || Int_Base.equal s acc.size); + make_loc (Location_Bits.join loc acc.loc) s + in + List.fold_left aux loc_bottom l + +exception Not_an_exact_loc + +let eval_term_as_exact_loc env result t = + match t.term_node with + | TLval _ -> + (match eval_tlval env result t with + | [] | _ :: _ :: _ -> raise Not_an_exact_loc + | [typ, loc] -> + let loc = Locations.make_loc loc (Bit_utils.sizeof typ) in + if not (valid_cardinal_zero_or_one ~for_writing:false loc) + then raise Not_an_exact_loc; + typ, loc + ) + | _ -> raise Not_an_exact_loc + +let rec reduce_by_predicate ~result env positive p = + let result = + match positive,p.content with + | true,Ptrue | false,Pfalse -> env + + | true,Pfalse | false,Ptrue -> + overwrite_current_state env Cvalue.Model.bottom + + | true,Pand (p1,p2 ) | false,Por(p1,p2)-> + let r1 = reduce_by_predicate ~result env positive p1 in + reduce_by_predicate ~result r1 positive p2 + + | true,Por (p1,p2 ) | false,Pand (p1, p2) -> + join_env + (reduce_by_predicate ~result env positive p1) + (reduce_by_predicate ~result env positive p2) + + | true,Pimplies (p1,p2) -> + join_env + (reduce_by_predicate ~result env false p1) + (reduce_by_predicate ~result env true p2) + + | false,Pimplies (p1,p2) -> + reduce_by_predicate ~result + (reduce_by_predicate ~result env true p1) + false + p2 + + | _,Pnot p -> reduce_by_predicate ~result env (not positive) p + + | true,Piff (p1, p2) -> + let red1 = + reduce_by_predicate ~result env true (Logic_const.pand (p1, p2)) in + let red2 = + reduce_by_predicate ~result env false (Logic_const.por (p1, p2)) in + join_env red1 red2 + + | false,Piff (p1, p2) -> + reduce_by_predicate ~result env true + (Logic_const.por + (Logic_const.pand (p1, Logic_const.pnot p2), + Logic_const.pand (Logic_const.pnot p1, p2))) + + | _,Pxor(p1,p2) -> + reduce_by_predicate ~result env + (not positive) (Logic_const.piff(p1, p2)) + + | _,Prel (op,t1,t2) -> + begin + try + let eval = match t1.term_type with + | t when isLogicRealOrFloatType t -> + eval_float (Value_parameters.AllRoundingModes.get ()) + | t when isLogicIntegralType t -> eval_int + | Ctype (TPtr _) -> eval_int + | _ -> raise Predicate_alarm + in + reduce_by_relation eval ~result env positive t1 op t2 + with + | Predicate_alarm -> env + | Reduce_to_bottom -> + overwrite_current_state env Cvalue.Model.bottom + ( if the exception was obtained without an alarm emitted, + it is correct to return the bottom state ) + end + + | _,Pvalid ({ term_node = TLval _} as t) -> + begin + try + let l = eval_tlval env result t in + let aux env (typ, lval) = + let loc = make_loc lval (Bit_utils.sizeof typ) in + if valid_cardinal_zero_or_one ~for_writing:false loc then + let state = + reduce_by_valid_loc ~positive ~for_writing:false + loc typ (env_current_state env) + in + overwrite_current_state env state + else env + in + List.fold_left aux env l + with Predicate_alarm -> env + end + | _, Pvalid _ -> env ( no way to reduce for now. ) + + | _,Pinitialized tsets -> + begin try + let locb = eval_term env result tsets in + List.fold_left + (fun env (e, loc) -> + let state = reduce_by_initialized_loc ~with_alarms:warn_raise_mode + ~positive (e, loc) (env_current_state env) + in + overwrite_current_state env state + ) env locb + with + | Predicate_alarm -> env + end + | _,Pat _ -> env + | _,Papp _ + | _,Pexists (_, _) | _,Pforall (_, _) + | _,Pvalid_range (_, _, _)| _,Pvalid_index (_, _) + | _,Plet (_, _) | _,Pif (_, _, _) + | _,Pfresh _ | _,Psubtype _ + | _, Pseparated _ + -> env + in + result + +and reduce_by_relation eval ~result env positive t1 rel t2 = + let env = reduce_by_left_relation eval ~result env positive t1 rel t2 in + let inv_binop = match rel with + | Rgt -> Rlt | Rlt -> Rgt | Rle -> Rge | Rge -> Rle + | _ -> rel + in + reduce_by_left_relation eval ~result env positive t2 inv_binop t1 + +and reduce_by_left_relation eval ~result env positive tl rel tr = + let with_alarms = warn_raise_mode in + try + let state = env_current_state env in + let typ_loc, loc = eval_term_as_exact_loc env result tl in + let value_for_loc = + Cvalue.Model.find ~conflate_bottom:true ~with_alarms state loc in + let value_for_loc = do_cast ~with_alarms typ_loc value_for_loc in + let cond_v = + List.fold_left (fun v (_, v') -> Location_Bytes.join v v') + Location_Bytes.bottom (eval_term env result tr) + in + let op = lop_to_cop rel in + let v_sym = eval.eval_symetric positive op cond_v value_for_loc in + let v_asym = eval.eval_antisymetric ~typ_loc positive op cond_v v_sym in + if V.equal v_asym V.bottom then raise Reduce_to_bottom; + if V.equal v_asym value_for_loc + then env + else + let state' = Cvalue.Model.reduce_binding ~with_alarms state loc v_asym in + overwrite_current_state env state' + with Predicate_alarm | Not_an_exact_loc -> env + + +let rec eval_predicate ~result env pred = + let rec do_eval env p = + match p.content with + | Ptrue -> True + | Pfalse -> False + | Pand (p1,p2 ) -> + begin match do_eval env p1 with + | True -> do_eval env p2 + | False -> False + | Unknown -> + let reduced = reduce_by_predicate ~result env true p1 in + match do_eval reduced p2 with + | False -> False + | _ -> Unknown + end + | Por (p1,p2 ) -> + let val_p1 = do_eval env p1 in + (Format.printf "Disjunction: state %a p1:%a@." + Cvalue.Model.pretty (env_current_state env) + Cil.d_predicate_named p1; ) + begin match val_p1 with + | True -> True + | False -> do_eval env p2 + | Unknown -> begin + let reduced_state = reduce_by_predicate ~result env false p1 in + ( Format.printf "Disjunction: reduced to %a to eval %a@." + Cvalue.Model.pretty (env_current_state reduced_state) + Cil.d_predicate_named p2; ) + match do_eval reduced_state p2 with + | True -> True + | _ -> Unknown + end + end + | Pxor (p1,p2) -> + begin match do_eval env p1, do_eval env p2 with + | True, True -> False + | False, False -> False + | True, False | False, True -> True + | Unknown, _ | _, Unknown -> Unknown + end + | Piff (p1,p2 ) -> + begin match do_eval env p1,do_eval env p2 with + | True, True | False, False -> True + | Unknown, _ | _, Unknown -> Unknown + | _ -> False + end + | Pat (p, lbl) -> begin + let _env = { env with e_cur = convert_label lbl } in + do_eval env p + end + | Papp _ -> Unknown + | Pvalid tsets -> begin + try + List.iter + (fun (typ, loc) -> + if not (isPointerType typ) + then raise Predicate_alarm ( TODO: global arrays ); + let size = sizeof_pointed typ in + let loc = loc_bytes_to_loc_bits loc in + let loc = Locations.make_loc loc size in + if not (Locations.is_valid ~for_writing:false loc) then ( + ( Maybe the location is guaranteed to be invalid? ) + (if Locations.cardinal_zero_or_one loc then + let valid = valid_part ~for_writing:false loc in + if Location_Bits.equal Location_Bits.bottom valid.loc + then raise Stop; + ); + raise Predicate_alarm + )) + (eval_term env result tsets); + True + with + | Predicate_alarm -> Unknown + | Stop -> False + end + | Pinitialized tsets -> begin + try + let locb = eval_term env result tsets in + fold_join_predicate List.fold_left + (fun (typ, loc) -> + let locbi = loc_bytes_to_loc_bits loc in + let size = match unrollType typ with + | TPtr (t, _) -> bitsSizeOf t + | _ -> assert false + in + let loc = make_loc locbi (Int_Base.inject (Int.of_int size)) in + let value = Cvalue.Model.find_unspecified + ~with_alarms:CilE.warn_none_mode (env_current_state env) loc + in + match value with + | Cvalue.V_Or_Uninitialized.C_uninit_esc v + | Cvalue.V_Or_Uninitialized.C_uninit_noesc v -> + if Location_Bytes.is_bottom v then False else Unknown + | Cvalue.V_Or_Uninitialized.C_init_esc _ + | Cvalue.V_Or_Uninitialized.C_init_noesc _ -> True + ) locb + with + | Cannot_find_lv + | Predicate_alarm -> Unknown + end + | Prel (op,t1,t2) -> begin + try + let t = t1.term_type in ( TODO: t1.term_type and t2.term_type are + sometimes different (Z vs. int, double vs. R, attribute const added, + etc). I think it is always correct to use any of the two types, + but I am not 100% sure ) + let trm = Logic_const.term (TBinOp (lop_to_cop op, t1, t2)) t in + let l = List.map snd (eval_term env result trm) in + if List.for_all + (Location_Bytes.equal Location_Bytes.singleton_zero) l + then False + else if List.for_all + (Location_Bytes.equal Location_Bytes.singleton_one) l + then True + else Unknown + with + | Predicate_alarm -> Unknown + end + | Pexists (varl, p1) | Pforall (varl, p1) -> + let result = + begin try + let env = List.fold_left + (fun acc var -> + match var.lv_origin with + | None -> raise Exit + | Some vi -> + let loc = loc_of_varinfo vi in + let state = + Cvalue.Model.add_binding + ~with_alarms:warn_raise_mode ~exact:true + (env_current_state acc) loc Location_Bytes.top + in + overwrite_current_state env state + ) env varl + in + do_eval env p1 + with + Exit -> Unknown + | Predicate_alarm -> Unknown + end + in + begin match p.content with + | Pexists _ -> if result = False then False else Unknown + | Pforall _ -> if result = True then True else Unknown + | _ -> assert false + end + + | Pnot p -> begin match do_eval env p with + | True -> False + | False -> True + | Unknown -> Unknown + end + | Pimplies (p1,p2) -> + do_eval env (Logic_const.por ((Logic_const.pnot p1), p2)) + | Pseparated (_tset_l) -> Unknown + | Pfresh _ + | Pvalid_range (_, _, _)| Pvalid_index (_, _) + | Plet (_, _) | Pif (_, _, _) + | Psubtype _ + -> Unknown + in + do_eval env pred + +exception Does_not_improve + +let rec fold_on_disjunction f p acc = + match p.content with + | Por (p1,p2 ) -> fold_on_disjunction f p2 (fold_on_disjunction f p1 acc) + | _ -> f p acc + +let count_disjunction p = fold_on_disjunction (fun _pred -> succ) p 0 + +let reduce_by_disjunction ~result ~env states n p = + if State_set.is_empty states + then states + else if (State_set.length states) (count_disjunction p) <= n + then begin + let treat_state acc state = + let env = overwrite_current_state env state in + let treat_pred pred acc = + let result = reduce_by_predicate ~result env true pred in + if Cvalue.Model.equal (env_current_state result) state + then raise Does_not_improve + else State_set.add (env_current_state result) acc + in + try + fold_on_disjunction treat_pred p acc + with + Does_not_improve -> State_set.add state acc + in + State_set.fold treat_state State_set.empty states + end + else + State_set.fold + (fun acc state -> + let env = overwrite_current_state env state in + let reduced = reduce_by_predicate ~result env true p in + State_set.add (env_current_state reduced) acc) + State_set.empty + states + +module ActiveBehaviors = struct + + let header b = + if Cil.is_default_behavior b then "" + else ", behavior " ^ b.b_name + + let is_active_aux init_states b = + let assumes = + (Logic_const.pands + (List.map Logic_const.pred_of_id_pred b.b_assumes)) + in + fold_join_predicate State_set.fold + (fun init -> eval_predicate ~result:None (env_pre_f init) assumes) + init_states + + type t = { + init_states: State_set.t; + funspec: funspec; + is_active: funbehavior -> predicate_value + } + + module HashBehaviors = Hashtbl.Make( + struct + type t = funbehavior + let equal b1 b2 = b1.b_name = b2.b_name + let hash b = Hashtbl.hash b.b_name + end) + + let create init_states kf = + let funspec = Kernel_function.get_spec kf in + let h = HashBehaviors.create 3 in + { is_active = + (fun b -> + try HashBehaviors.find h b + with Not_found -> + let active = is_active_aux init_states b in + HashBehaviors.add h b active; + active + ); + init_states = init_states; + funspec = funspec; + } + + let active ba = ba.is_active + + let is_active ba b = active ba b != False + + exception No_such_behavior + + let behavior_from_name ab b = + try List.find (fun b' -> b'.b_name = b) ab.funspec.spec_behavior + with Not_found -> raise No_such_behavior + + let active_behaviors ab = + List.filter (is_active ab) ab.funspec.spec_behavior + + (* Is the behavior b the only one currently active. Check if it is in a + group of complete behaviors, and the only one active in its group. + TODO: we should also check that we can prove the 'complete' clause ) + let only_active ab b = + assert (is_active ab b); + let none_other_active group = + let other_not_active b'_name = + b'_name = b.b_name || + (let b' = behavior_from_name ab b'_name in not (is_active ab b')) + in + List.for_all other_not_active group + in + try + let complete = + List.find (List.mem b.b_name) ab.funspec.spec_complete_behaviors + in + none_other_active complete + with + Not_found | No_such_behavior -> false + +end + + +let check_postconditions kf kinstr ~result ~slevel header ~init_state ~active_behaviors ~post_state kind behaviors = + let fused_init = State_set.join init_state in + ( TODO BY: not optimal in reduce_by_disjunction below ) + let e_post = + lazy (env_post_f ~post:(State_set.join post_state) ~pre:fused_init) + in + let incorporate_behavior state b = + if b.b_post_cond = [] then state + else + let header = header ^ ActiveBehaviors.header b in + let posts = List.filter (fun (x,_) -> x = kind) b.b_post_cond in + let update_status st post = + let ip = Property.ip_of_ensures kf kinstr b post in + emit_status ip st + in + match ActiveBehaviors.active active_behaviors b with + | True -> + List.fold_left + (fun acc (_,{ip_content=pred;ip_loc=loc} as post) -> + let source = fst loc in + if State_set.is_empty acc then + (Value_parameters.result ~once:true ~source + "%s: no state left to evaluate postcondition, status not computed.%t" + header pp_callstack; + acc) + else + let pred = Ast_info.predicate loc pred in + let res = fold_join_predicate State_set.fold + (fun state -> + let env = env_post_f ~post:state ~pre:fused_init in + eval_predicate ~result env pred) acc + in + Value_parameters.result ~once:true ~source + "%s: postcondition got status %a.%t" + header pretty_predicate_value res pp_callstack; + match res with + | False -> + update_status Property_status.False_if_reachable post; + State_set.empty + | True -> + update_status Property_status.True post; + ( The reduction is needed in the True case, + because the function is "reduce_by_disjunction". + Example: //@ assert x<0 || x>=0; ) + reduce_by_disjunction ~result ~env:!!e_post acc slevel pred + | Unknown -> + update_status Property_status.Dont_know post; + reduce_by_disjunction ~result ~env:!!e_post acc slevel pred + ) state posts + | Unknown -> + List.fold_left + (fun acc (_,{ip_content=pred;ip_loc=loc} as post) -> + let source = fst loc in + if State_set.is_empty acc then + (Value_parameters.result ~once:true ~source + "%s: no state left to evaluate postcondition, status not computed.%t" + header pp_callstack; + acc) + else + let pred = Ast_info.predicate loc pred in + let res = fold_join_predicate State_set.fold + (fun state -> + let env = env_post_f ~post:state ~pre:fused_init in + eval_predicate ~result env pred) + acc + in + Value_parameters.result ~once:true ~source + "%s: postcondition got status %a.%t" + header pretty_predicate_value res pp_callstack; + match res with + | Unknown | False -> + update_status Property_status.Dont_know post; + Value_parameters.result ~once:true ~source + "%s: postcondition got status %a, \ +but it is unknown if the behavior is active.%t" + header pretty_predicate_value res pp_callstack; + state + | True -> + update_status Property_status.True post; + Value_parameters.result ~once:true ~source + "%s: postcondition got status %a, \ +but it is unknown if the behavior is active.%t" + header pretty_predicate_value res pp_callstack; + state + ) state posts + | False -> + ( if assumes is false, post-condition status is not updated ) + (match posts with + | [] -> () + | (_,{ip_loc=(source,_)})::_ -> + Value_parameters.result ~once:true ~source + "%s: assumes got status invalid; post-condition not evaluated.%t" + header pp_callstack); + state + in + List.fold_left incorporate_behavior post_state behaviors + +let check_fct_postconditions ~result kf ~init_state ~active_behaviors + ~post_state kind = + try + let spec = (Kernel_function.get_spec kf).spec_behavior in + let slevel = get_slevel kf in + check_postconditions kf Kglobal ~result ~slevel + (Pretty_utils.sfprintf "Function %a@?" Kernel_function.pretty kf) + ~init_state ~active_behaviors ~post_state kind spec + with Not_found -> post_state + +let check_preconditions kf kinstr ~slevel header active_behaviors + init_state spec = + let env = env_pre_f (State_set.join init_state) in + let incorporate_behavior states b = + if b.b_requires = [] then states + else + let header = header ^ ActiveBehaviors.header b in + let update_status st vc = + let ip = Property.ip_of_requires kf kinstr b vc in + emit_status ip st + in + match ActiveBehaviors.active active_behaviors b with + | True -> + List.fold_left (fun state ({ip_content=pr;ip_loc=loc} as pre) -> + let source = fst loc in + if State_set.is_empty state then + (Value_parameters.result ~once:true ~source + "%s: no state in which to evaluate precondition, status not computed.%t" + header pp_callstack; + state) + else + let pr = Ast_info.predicate loc pr in + let res = fold_join_predicate State_set.fold + (fun state -> + eval_predicate ~result:None (env_pre_f state) pr) + state + in + Value_parameters.result ~once:true ~source + "%s: precondition got status %a.%t" + header pretty_predicate_value res pp_callstack; + match res with + | False -> + update_status Property_status.False_if_reachable pre; + State_set.empty + | True -> + update_status Property_status.True pre; + ( The reduction is needed in the True case, + because the function is "reduce_by_disjunction". + Example: //@ assert x<0 || x>=0; ) + reduce_by_disjunction ~result:None ~env state slevel pr + | Unknown -> + update_status Property_status.Dont_know pre; + reduce_by_disjunction ~result:None ~env state slevel pr + ) states b.b_requires + | Unknown -> + List.fold_left + (fun state ({ip_content=pr;ip_loc=loc} as pre) -> + let source = fst loc in + if State_set.is_empty state then + (Value_parameters.result ~once:true ~source + "%s: no state in which to evaluate precondition, status not computed.%t" + header pp_callstack; + state) + else + let pr = Ast_info.predicate loc pr in + let res = fold_join_predicate State_set.fold + (fun state -> + eval_predicate ~result:None (env_pre_f state) pr) + state + in + Value_parameters.result ~once:true ~source:(fst loc) + "%s: precondition got status %a.%t" + header pretty_predicate_value res pp_callstack; + match res with + | Unknown | False -> + update_status Property_status.Dont_know pre; + Value_parameters.result ~once:true ~source + "%s: precondition got status %a, \ +but it is unknown if the behavior is active.%t" + header pretty_predicate_value res pp_callstack; + state + | True -> + update_status Property_status.True pre; + Value_parameters.result ~once:true ~source + "%s: precondition got status %a.%t" + header pretty_predicate_value res pp_callstack; + state + ) states b.b_requires + | False -> + ( if assumes is false, post-condition status is not updated *) + (match b.b_requires with + | [] -> () + | {ip_loc=(source,_)}::_ -> + Value_parameters.result ~once:true ~source + "%s: assumption got status invalid; precondition not evaluated.%t" + header pp_callstack); + states + in + List.fold_left + incorporate_behavior + init_state spec.spec_behavior + +(** Check the precondition of [kf]. This may result in splitting [init_state] + into multiple states if the precondition contains disjunctions. The active + behaviors are computed wrt [init_state], but further computations on [kf] + will use active behaviors computed wrt the result of this function. ) +let check_fct_preconditions kf init_state = + let init_states = State_set.singleton init_state in + try + let spec = Kernel_function.get_spec kf in + let slevel = get_slevel kf in + let active_behaviors = ActiveBehaviors.create init_states kf in + check_preconditions kf Kglobal ~slevel + (Pretty_utils.sfprintf "Function %a@?" Kernel_function.pretty kf) + active_behaviors init_states spec + with Not_found -> init_states + + +let () = + Db.Value.valid_behaviors := + (fun kf state -> + let ab = ActiveBehaviors.create (State_set.singleton state) kf in + ActiveBehaviors.active_behaviors ab + ); + Db.Properties.Interp.loc_to_loc := + (fun ~result state t -> + try eval_tlval_as_location (env_pre_f state) result t + with Predicate_alarm -> raise (Invalid_argument "not an lvalue") + ) + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval.ml frama-c-20111001+nitrogen+dfsg/src/value/eval.ml --- frama-c-20110201+carbon+dfsg/src/value/eval.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,5434 +0,0 @@ -(**************************************************************************) -(* ) -( This file is part of Frama-C. ) -( ) -( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( ) -( you can redistribute it and/or modify it under the terms of the GNU ) -( Lesser General Public License as published by the Free Software ) -( Foundation, version 2.1. ) -( ) -( It 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 Lesser General Public License for more details. ) -( ) -( See the GNU Lesser General Public License version 2.1 ) -( for more details (enclosed in the file licenses/LGPLv2.1). ) -( *) -(************************************************************************) - -( Analysis for values and pointers ) - -open Cil_types -open Cil -open Cilutil -open Cil_datatype -module Ki = Cil_datatype.Kinstr ( do not mask kinstr in src/value ) -open Db_types -open Locations -open Abstract_interp -open Abstract_value -open Bit_utils -open Cvalue_type -open Extlib -open Ast_printer -open Value_util - -let make_status st = Checked {emitter = "value analysis"; valid = st} -let status_true = make_status Cil_types.True -let status_false = make_status Cil_types.False -let status_maybe = make_status Cil_types.Maybe - -module Status: sig - val join: Property.t -> annotation_status -> unit -end = -struct - - module S = - Properties_status.Make_updater - (struct - let name = "Value" - let emitter = Db.Value.self - end) - -( let () = - List.iter (fun self -> - Project.State_builder.add_dependency - Db.Value.self - self - ) - [] - (* used to be dependent on a state such as - Properties_status.RTE_Status_Proxy, but not - a good idea after all - ) -) - let merge old_s new_s = match old_s, new_s with - | Cil_types.Unknown, status | status, Cil_types.Unknown -> - status - | Checked { valid = Maybe },Checked _ - | Checked _ ,Checked { valid = Maybe } - -> status_maybe - | Checked {valid = s1 }, Checked {valid = s2 } when s1 = s2 -> - (* Do not share with argument to be on the safe side ) - make_status s1 - | _ -> status_maybe - - let join ip status = - ignore (S.update ip [] (fun old -> merge old status)) - -end - -type cond = - { exp: exp; ( The condition of the branch) - positive: bool; ( true: normal false: negated )} - -let get_slevel kf = - let name = Kernel_function.get_name kf in - Value_parameters.SlevelFunction.find name - -( Returns boolean telling to display a warning, - and optionally reduce the values of [ev1] and [ev2], - knowing that they are involved in a comparison ) -let check_comparable ev1 ev2 = - try - if not (Location_Bytes.is_included ev1 Location_Bytes.top_int) - || not (Location_Bytes.is_included ev2 Location_Bytes.top_int) - then begin - ( First check if a non-zero integer is compared to an address ) - let null_1, rest_1 = Location_Bytes.split Base.null ev1 in - let null_2, rest_2 = Location_Bytes.split Base.null ev2 in - if (not (Ival.is_included null_1 Ival.zero)) && - (not (Location_Bytes.equal rest_2 Location_Bytes.bottom )) - then raise Not_found; - if (not (Ival.is_included null_2 Ival.zero)) && - (not (Location_Bytes.equal rest_1 Location_Bytes.bottom )) - then raise Not_found; - - ( If both addresses are valid, they can be compared. - If one/both is not valid, the only way they can be - compared is if they are offsets in a same array t. - In this case, if t+n is the address of the last valid - location in t, t+n+1 is allowed in the comparison. - FIXME: Take string literals into account. ) - let loc1 = make_loc (loc_bytes_to_loc_bits rest_1) Int_Base.one in - if (not (Locations.is_valid_or_function loc1)) || - let loc2 = make_loc (loc_bytes_to_loc_bits rest_2) Int_Base.one in - (not (Locations.is_valid_or_function loc2)) - then begin - let base_1, _offs_1 = Location_Bytes.find_lonely_key rest_1 in - let base_2, _offs_2 = Location_Bytes.find_lonely_key rest_2 in - if Base.compare base_1 base_2 <> 0 then raise Not_found; - ( TODO ) - end - end; - false, ev1, ev2 - with Not_found -> - true, ev1, ev2 - - -module type Domain = sig - type state - val eval_expr : - with_alarms:CilE.warn_mode -> state -> exp -> stateCvalue_type.V.t - val do_assign : with_alarms:CilE.warn_mode -> state -> lval -> exp -> state - val eval_cond : with_alarms:CilE.warn_mode -> state -> cond -> state - val widen : state -> state -> state - val join : state -> state -> state - val call : kernel_function -> state -> state - val return : kernel_function -> state -> state - -end - -module PtrRelational = struct - type state = Relations_type.Model.t - let eval_expr ~with_alarms state expr = match expr.enode with - | BinOp ((MinusA | MinusPP | Eq | Ne | Ge | Le | Gt | Lt as op),e1,e2,_) -> - let state, ev1 = !Db.Value.eval_expr_with_state ~with_alarms state e1 in - let state, ev2 = !Db.Value.eval_expr_with_state ~with_alarms state e2 in - CilE.set_syntactic_context (CilE.SyBinOp (op,e1,e2)); - begin - match unrollType (typeOf e1) with - | TFloat _ -> - state,Cvalue_type.V.top - | TInt _ | TPtr (_, _) | _ (* Enum ? ) -> - let compute_diff acc = - let lv1 = !Db.Value.find_lv_plus ~with_alarms state e1 in - let lv2 = !Db.Value.find_lv_plus ~with_alarms state e2 in - List.fold_left - (fun acc (lv1, offs1) -> - let loc1 = !Db.Value.lval_to_loc_state state lv1 in - List.fold_left - (fun acc (lv2, offs2) -> - let loc2 = !Db.Value.lval_to_loc_state state lv2 in - try - let new_v = - V.location_shift - (Ival.sub offs1 offs2) - (Relations_type.Model.compute_diff - state loc1 loc2) - in - assert (V.is_included new_v acc); - new_v - with Relations_type.Use_Main_Memory -> acc) - acc - lv2) - acc - lv1 - in - match op with - | MinusA -> state,compute_diff Cvalue_type.V.top - | MinusPP -> - let minus_val = compute_diff Cvalue_type.V.top in - let r = - try - let size = Int_Base.project - (sizeof_pointed(Cil.typeOf e1)) - in - let size = Int.div size Int.eight in - if Int.is_one size then - minus_val - else - let minus_val = - Cvalue_type.V.project_ival minus_val - in - Cvalue_type.V.inject_ival - (Ival.scale_div ~pos:true size minus_val) - with - Int_Base.Error_Top - | Cvalue_type.V.Not_based_on_null - | Not_found -> - V.join - (V.topify_arith_origin ev1) - (V.topify_arith_origin ev2) - in - state, r - | Eq | Ne | Ge | Le | Gt | Lt -> - let r = - let warn, ev1, ev2 = check_comparable ev1 ev2 in - if warn - then begin - CilE.warn_pointer_comparison with_alarms; - end; - if warn && Value_parameters.UndefinedPointerComparisonPropagateAll.get () - then V.zero_or_one - else - let f = match op with - | Eq -> V.check_equal true - | Ne -> V.check_equal false - | Ge -> V.comparisons ">=" V.do_ge - | Le -> V.comparisons "<=" V.do_le - | Gt -> V.comparisons ">" V.do_gt - | Lt -> V.comparisons "<" V.do_lt - | _ -> assert false - in - let diff = compute_diff V.top in - let result = f diff V.singleton_zero in - if V.cardinal_zero_or_one result - then result - else f ev1 ev2 - in - state, r - - | _ -> state,Cvalue_type.V.top - - end - | _ -> state,Cvalue_type.V.top -end - - -( set the value to false for debugging value analysis without relations ) -module UseRelations = - State_builder.Ref - (Datatype.Bool) - (struct let name = "UseRelations" - let dependencies = [] - let kind = `Internal - let default () = true - end) - -let () = - State_dependency_graph.Static.add_dependencies - ~from:UseRelations.self [ Db.Value.self ] - -let compute_call_ref = ref (fun _ -> assert false) - -let remember_bases_with_locals bases_containing_locals left_loc evaled_exp = - if Cvalue_type.V.contains_addresses_of_any_locals evaled_exp then - let clobbered_set = Location_Bits.get_bases left_loc.loc in - bases_containing_locals := - Location_Bits.Top_Param.join clobbered_set !bases_containing_locals - -let timer = ref 0 - -let set_loc kinstr = - match kinstr with - | Kglobal -> CurrentLoc.clear () - | Kstmt s -> CurrentLoc.set (Stmt.loc s) - -exception Leaf ( raised when nothing is known for a function : - no source nor specification ) - -exception Not_an_exact_loc - -exception Reduce_to_bottom - - -module Got_Imprecise_Value = - State_builder.Ref - (Datatype.Bool) - (struct - let name = "Eval.Got_Imprecise_Value" - let dependencies = [ Db.Value.self ] - let kind = `Internal - let default () = false - end) - -module Location_list = Datatype.List (Locations.Location) - -module Non_linear_assignments = - Cil_state_builder.Varinfo_hashtbl - (Ki.Hashtbl.Make(Location_list)) - (struct - let name = "Non linear assignments" - let size = 37 - let dependencies = [ Ast.self ] - let kind = `Internal - end) - - -let pretty_current_cfunction_name fmt = - Kernel_function.pretty_name fmt (current_kf()) - -exception Offset_not_based_on_Null of - Locations.Zone.t option Location_Bytes.t - -let warn_locals_escape is_block fundec k = - (TODO: find a better alarm for variables escaping block scope ) - Value_parameters.warning ~current:true ~once:true - "local escaping the scope of %t%a through %a" - (swap (Pretty_utils.pp_cond is_block) "a block of ") - !d_var fundec.svar - Base.pretty k - -let warn_locals_escape_result fundec = - Value_parameters.warning ~current:true ~once:true - "local escaping the scope of %a through \\result" - !d_var fundec.svar - -let do_cast ~with_alarms t expr = - let treat inttype = - match inttype with - | TInt(kind,_) -> - let size = Int.of_int (bitsSizeOf inttype) in - let signed = isSigned kind in - V.cast ~with_alarms ~signed ~size expr - | TFloat (FFloat,_) -> - let addresses, overflow, res = V.cast_float expr in - if addresses - then Value_parameters.warning ~current:true ~once:true - "addresses in float"; - if overflow then Value_parameters.warning ~current:true ~once:true - "overflow in float: %a -> %a. assert(Ook)" - V.pretty expr V.pretty res; - res - | TFloat (FDouble,_) -> - expr - | TFloat (FLongDouble,_) -> - expr - | _ -> assert false - in - match unrollType t with - | TInt _ | TFloat _ as t' -> - treat t' - | TPtr _ -> - treat theMachine.upointType - | TEnum _ -> - if theMachine.enum_are_signed then - treat (TInt(IInt,[])) - else treat (TInt(IUInt,[])) - | TComp _ -> expr (* see test [struct_call.c] ) - | TBuiltin_va_list _ -> - (match with_alarms.CilE.imprecision_tracing with - | CilE.Aignore -> () - | CilE.Acall f -> f () - | CilE.Alog -> - Value_parameters.warning ~once:true ~current:true - "cast to __builtin_va_list is not precisely implemented yet"); - V.topify_arith_origin expr - | TFun _ -> expr - | TNamed _ -> assert false - | TVoid _ -> assert false - | TArray _ -> assert false - -let do_promotion ~with_alarms ~src_typ ~dest_type v e_src = - match dest_type, src_typ with - | TFloat _, TInt _ -> - Cvalue_type.V.cast_int_to_float ~with_alarms (get_rounding_mode()) v - | TInt (kind,_), TFloat _ -> - let size = bitsSizeOf dest_type in - let signed = isSigned kind in - let alarm_use_as_float, alarm_overflow, r = - Cvalue_type.V.cast_float_to_int ~signed ~size v - in - if alarm_use_as_float - then begin - Value_parameters.warning ~current:true ~once:true - "converting %a to float: assert(Ook)" - !d_exp e_src; - end; - if alarm_overflow - then - Value_parameters.warning ~current:true ~once:true - "Overflow in cast of %a (%a) from floating-point to integer: assert(Ook)" - !d_exp e_src - Cvalue_type.V.pretty v; - r - | _, _ -> v - -let handle_signed_overflow ~with_alarms syntactic_context typ e interpreted_e = - match unrollType typ with - TInt(kind, _) - when Value_parameters.SignedOverflow.get() - && isSigned kind -> - let size = bitsSizeOf typ in - let mn, mx = - let b = Int.power_two (size-1) in - Int.neg b, Int.pred b - in - let mn64 = Int.to_int64 mn in - let mx64 = Int.to_int64 mx in - let warn_under, warn_over = - try - let i = V.project_ival interpreted_e in - let imn, imx = Ival.min_and_max i in - let u = - match imn with - Some bound when Int.ge bound mn -> None - | _ -> Some mn64 - in - let o = - match imx with - Some bound when Int.le bound mx -> None - | _ -> Some mx64 - in - u, o - with V.Not_based_on_null -> - Some mn64, Some mx64 - in - let all_values = - Cvalue_type.V.inject_ival (Ival.inject_range (Some mn) (Some mx)) - in - if V.is_included interpreted_e all_values - then interpreted_e - else begin - CilE.set_syntactic_context syntactic_context; - CilE.warn_signed_overflow with_alarms e - warn_under warn_over; - let r = V.narrow all_values interpreted_e in - Value_parameters.debug - "signed overflow: %a reduced to %a@." - V.pretty interpreted_e - V.pretty r; - r - end - | _ -> interpreted_e - -exception Cannot_find_lv - -exception Too_linear - -let warn_lval_read lv loc contents = - let pretty_param fmt param = - match param with - | Location_Bits.Top_Param.Top -> Format.fprintf fmt "is imprecise" - | Location_Bits.Top_Param.Set _s -> - Format.fprintf fmt "is a garbled mix of %a" - Location_Bits.Top_Param.pretty param - in - let pretty_param_b fmt param = - match param with - | Location_Bytes.Top_Param.Top -> - Format.fprintf fmt "The contents is imprecise" - | Location_Bytes.Top_Param.Set _s -> - Format.fprintf fmt "It contains a garbled mix of %a" - Location_Bytes.Top_Param.pretty param - in - let something_to_warn = - match loc.loc with Location_Bits.Top _ -> true - | Location_Bits.Map _ -> - match contents with - | Location_Bytes.Top _ -> true - | Location_Bytes.Map _ -> false - in - if something_to_warn then - Value_parameters.result ~current:true ~once:true - "reading left-value @[%a@].@ @[%t%t@]" - !Ast_printer.d_lval lv - (fun fmt -> - match lv with - | Mem _, _ -> - (match loc.loc with - | Location_Bits.Top (param,o) when Origin.equal o Origin.top -> - Format.fprintf fmt "The location %a. " - pretty_param param - | Location_Bits.Top (param,orig) -> - Format.fprintf fmt "The location @[%a@]@ because of@ @[%a@],@ " - pretty_param param - Origin.pretty orig - | Location_Bits.Map _ -> - Format.fprintf fmt "The location is @[%a@].@ " - Location_Bits.pretty loc.loc) - | Var _, _ -> ()) - (fun fmt -> - match contents with - | Location_Bytes.Top (param,o) when Origin.equal o Origin.top -> - Format.fprintf fmt "@[%a.@]" - pretty_param_b param - | Location_Bytes.Top (param,orig) -> - Format.fprintf fmt "@[%a@]@ because of@ @[%a.@]" - pretty_param_b param - Origin.pretty orig - | Location_Bytes.Map _ -> ()) - -let rec lval_to_loc ~with_alarms state lv = - let _,_,r = - lval_to_loc_deps_option - ~with_alarms - ~deps:None - ~reduce_valid_index:(Parameters.SafeArrays.get ()) - state - lv - in - r - -and lval_to_loc_deps_option - ~with_alarms ~deps (state:Relations_type.Model.t) ~reduce_valid_index - (base,offset as lv) = - if not (Relations_type.Model.is_reachable state) then - state, deps, loc_bottom - else - let typ = match base with - | Var host -> host.vtype - | Mem x -> typeOf x - in - try - let state, deps, offs = - eval_offset - ~reduce_valid_index - ~with_alarms deps typ state offset - in - base_to_loc ~with_alarms ?deps state lv base offs - with Offset_not_based_on_Null(deps,offset) -> - let state, deps, loc_if_there_wasnt_offset = - base_to_loc ~with_alarms ?deps state lv base Ival.zero - in - state, deps, - loc_bits_to_loc lv - (Location_Bits.join - (loc_bytes_to_loc_bits offset) - loc_if_there_wasnt_offset.loc) - -( pc says: only called in addrOf ) -and lval_to_loc_with_offset_deps_only - ~deps (state:Relations_type.Model.t) v - = - lval_to_loc_with_offset_deps_only_option ~deps:(Some deps) state v - -and lval_to_loc_with_deps ~deps state lv ~with_alarms = - lval_to_loc_deps_option ~with_alarms ~deps:(Some deps) state lv - -( pc says: only called in addrOf *) -and lval_to_loc_with_offset_deps_only_option - ~with_alarms ~deps (state:Relations_type.Model.t) (_base, _offset as v) - = - lval_to_loc_deps_option - ~with_alarms ~deps (state:Relations_type.Model.t) (v) - ~reduce_valid_index:false - - -(** Detects if an expression can be considered as a lvalue even though - it is hidden by a cast that does not change the lvalue. - Raises [exn] if it is not an lvalue. - - TODO: When the goal is to recognize the form (cast)l-value == expr, - it would be better and more powerful to have chains of inverse functions ) - -and pass_cast ~with_alarms state exn typ e = - ( type might be the same but their attributes. - But volatile attribute cannot be skipped ) - if not (Cilutil.equals - (typeSigWithAttrs (filterAttributes "volatile") typ) - (typeSigWithAttrs (filterAttributes "volatile") (typeOf e))) - then - (try - let typeofe = typeOf e in - ( Any volatile attribute may have an effect on the expression value ) - if hasAttribute "volatile" (typeAttrs typeofe) - || hasAttribute "volatile" (typeAttrs typ) - then raise exn; - let sztyp = sizeof typ in - let szexpr = sizeof typeofe in - let typ_ge_typeofe = - match sztyp,szexpr with - Int_Base.Value styp, Int_Base.Value sexpr -> Int.ge styp sexpr - | _ -> false - in - if not typ_ge_typeofe then raise exn; - let sityp = is_signed_int_enum_pointer typ in - let sisexpr = is_signed_int_enum_pointer (typeOf e) in - if sityp = sisexpr then () - ( destination type is larger and has the same sign as - the original type ) - else begin ( try to ignore the cast if it acts as identity - on the value [e] even if signed/unsigned - conflict. ) - match unrollType typ with - | TInt _ | TEnum _ -> - let size = Int.of_int (bitsSizeOf typ) in - let signed = sityp in - (try - let old_ival = V.project_ival - (eval_expr ~with_alarms state e) - in - if (Ival.equal - old_ival - (Ival.cast ~size ~signed ~value:old_ival)) - then () ( [e] is not sensitive to cast ) - else raise exn - with - | Not_found - | V.Not_based_on_null -> - raise exn) - ( this is not always injective, thus cannot be - easily reverted. ) - | _ -> raise exn - end - with Neither_Int_Nor_Enum_Nor_Pointer - -> raise exn) - -and find_lv ~with_alarms (state:Relations_type.Model.t) ee = - ( [BM] Do not recognize an lval whenever a volatile is involved to - prevent copy/paste optimization. IS THIS THE RIGHTPLACE PC ?) - if hasAttribute "volatile" (typeAttrs (typeOf ee)) then - raise Cannot_find_lv; - match ee.enode with - | Lval lv -> lv - | CastE (typ,e) -> - ( match unrollType typ, unrollType (typeOf e) with - TFloat (FDouble,_), TFloat _ -> find_lv ~with_alarms state e - ( see remark at pass_cast about inverse functions ) - | _ -> - pass_cast ~with_alarms state Cannot_find_lv typ e; - find_lv ~with_alarms state e) - | _ -> raise Cannot_find_lv - -and find_lv_plus ~with_alarms state e = - let acc = ref [] in - let rec find_lv_plus_rec e current_offs = - try - let lv = find_lv ~with_alarms state e in - if not (hasAttribute "volatile" (typeAttrs (Cil.typeOfLval lv))) - then acc := (lv,current_offs) :: !acc - with Cannot_find_lv -> - match e.enode with - BinOp(op, e1, e2, typ) -> - begin - match unrollType typ with - TFloat _ -> () - | _ -> begin - match op with - PlusA -> - let ev1 = eval_expr ~with_alarms state e1 in - let ev2 = eval_expr ~with_alarms state e2 in - ( try - let ival1 = V.project_ival ev1 in - find_lv_plus_rec e2 (Ival.add current_offs ival1) - with V.Not_based_on_null -> ()); - ( try - let ival2 = V.project_ival ev2 in - find_lv_plus_rec e1 (Ival.add current_offs ival2) - with V.Not_based_on_null -> ()); - | (MinusA|MinusPI|PlusPI|IndexPI as b) -> - let ev2 = eval_expr ~with_alarms state e2 in - ( try - let ival2 = V.project_ival ev2 in - let ival2 = - if b = MinusA - then ival2 - else - let ival2 = - Ival.scale - (Int_Base.project (osizeof_pointed typ)) - ival2 - in - if b = MinusPI - then ival2 - else Ival.neg ival2 - in - find_lv_plus_rec e1 (Ival.sub current_offs ival2) - with V.Not_based_on_null | Int_Base.Error_Top-> ()); - | _ -> () - end - end - | CastE(typ,e) -> - ( try - pass_cast ~with_alarms state Cannot_find_lv typ e; - find_lv_plus_rec e current_offs - with Cannot_find_lv -> ()) - | _ -> () - in - find_lv_plus_rec e Ival.singleton_zero; - (List.iter - (fun (lv,ival) -> - ignore (Pretty.printf "find_lv_plus %a : %s\n" - d_lval lv - (pretty_to_string Ival.pretty ival))) - !acc;) - !acc - -and base_to_loc ~with_alarms ?deps state lv base offs = - if Ival.equal Ival.bottom offs - then begin - Relations_type.Model.bottom, - (Some Zone.bottom), - loc_bits_to_loc lv Location_Bits.bottom - end - else - let result = match base with - | Var host -> - let base = Base.find host in - state, deps, - loc_bits_to_loc lv (Location_Bits.inject base offs) - | Mem x -> - let state, deps, loc_lv = - eval_expr_with_deps_state ~with_alarms deps state x - in - let loc_bits = - Location_Bits.location_shift - offs - (loc_bytes_to_loc_bits loc_lv) - in - state, deps, loc_bits_to_loc lv loc_bits - in - CilE.set_syntactic_context (CilE.SyMem lv); - result - -and eval_expr ~with_alarms state e = - snd (eval_expr_with_deps ~with_alarms None state e) - -and get_influential_vars ~with_alarms state cond = - ( Format.printf "get_influential cond:%a@.state:%a@." - !d_exp cond - Relations_type.Model.pretty state; ) - let rec get_vars acc cond = - match cond.enode with - | Lval (Var v, off as lv) -> - let offset = - try - let _, _, offset = - eval_offset ~reduce_valid_index:true ~with_alarms None - v.vtype state off - in - offset - with Offset_not_based_on_Null _ -> - Ival.top - in - if Ival.cardinal_zero_or_one offset - then - ( no variable in offset can be influential ) - let varid = Base.create_varinfo v in - let loc = - Locations.make_loc - (Locations.Location_Bits.inject varid offset) - (sizeof_lval lv) - in - let contents = - Relations_type.Model.find ~conflate_bottom:true - state ~with_alarms loc - in - if Location_Bytes.cardinal_zero_or_one contents - then ( - ( Format.printf "cond:%a@.var contents:%a@.state:%a@." - !d_exp cond - Location_Bytes.pretty contents - Relations_type.Model.pretty state; ) - acc ( it's not influential ) - ) - else loc :: acc - else - ( a variable in offset can be influential ) - get_vars_offset acc off - | Lval (Mem e, off) -> - get_vars_offset (get_vars acc e) off - | BinOp(_,v1,v2,_) -> - get_vars (get_vars acc v1) v2 - | UnOp(_,v1,_) -> - get_vars acc v1 - | CastE (_typ,exp) -> - get_vars acc exp - | _ -> acc - and get_vars_offset acc offset = - match offset with - NoOffset -> acc - | Field (_,off) -> get_vars_offset acc off - | Index (ind,off) -> get_vars (get_vars_offset acc off) ind - in - get_vars [] cond - -and reduce_by_valid_expr ~with_alarms ~positive exp state = - try - ignore (with_alarms); - let lv = - match exp.enode with - Lval lv -> lv - | _ -> raise Cannot_find_lv - in - ( TODO: utiliser find_lv_plus pour traiter plus d'expressions ) - let loc = lval_to_loc ~with_alarms:CilE.warn_none_mode state lv in - if not (Locations.valid_cardinal_zero_or_one loc) - then state - else - let value = - Relations_type.Model.find - ~conflate_bottom:true - ~with_alarms:CilE.warn_none_mode - state - loc - in - ( match value with - Location_Bytes.Top _ -> - ( we won't reduce anything anyway, - and we may lose information if loc contains misaligned data ) - raise Cannot_find_lv - | _ -> () ); - let value_as_loc = - make_loc - (loc_bytes_to_loc_bits value) - (sizeof_pointed (Cil.typeOfLval lv)) - in - let reduced_value = - loc_to_loc_without_size - (if positive - then valid_part value_as_loc - else invalid_part value_as_loc ) - in - if Location_Bytes.equal value reduced_value - then state - else begin - if Location_Bytes.equal Location_Bytes.bottom reduced_value - then Relations_type.Model.bottom - else - Relations_type.Model.reduce_binding - state - loc - reduced_value - end - with Cannot_find_lv -> state - -and eval_expr_with_deps ~with_alarms deps (state : Relations_type.Model.t) e = - let _,deps,r = eval_expr_with_deps_state ~with_alarms deps state e in - deps, r - -and eval_BinOp ~with_alarms e deps state = - match e.enode with - BinOp (op, e1, e2, typ) -> - let state, deps, ev1 = - eval_expr_with_deps_state ~with_alarms deps state e1 - in - if V.is_bottom ev1 - then Relations_type.Model.bottom, (Some Zone.bottom) ,V.bottom - else - let state, deps, ev2 = - eval_expr_with_deps_state ~with_alarms deps state e2 - in - if V.is_bottom ev2 - then Relations_type.Model.bottom, (Some Zone.bottom) ,V.bottom - else begin - let syntactic_context = CilE.SyBinOp (op,e1,e2) in - CilE.set_syntactic_context syntactic_context; - begin match unrollType (typeOf e1) with - | TFloat _ -> - let interpreted_expr = - ( refactor: shouldn't this be somewhere else? ) - try - let f1 = - try - let v1 = V.project_ival ev1 in - Ival.project_float v1 - with V.Not_based_on_null - | Ival.Float_abstract.Nan_or_infinite -> - Value_parameters.warning ~current:true ~once:true - "converting value to float: assert(Ook)"; - Ival.Float_abstract.top - in - let f2 = - try - let v2 = V.project_ival ev2 in - Ival.project_float v2 - with V.Not_based_on_null - | Ival.Float_abstract.Nan_or_infinite -> - Value_parameters.warning ~current:true ~once:true - "converting value to float: assert(Ook)"; - Ival.Float_abstract.top - in - let binary_float_floats _name f = - CilE.set_syntactic_context (CilE.SyUnOp e); - try - let alarm, f = f (get_rounding_mode ()) f1 f2 in - if alarm then begin - CilE.warn_result_nan_infinite with_alarms ; - end; - V.inject_ival (Ival.inject_float f) - with - Ival.Float_abstract.Nan_or_infinite -> - CilE.warn_result_nan_infinite with_alarms ; - V.top_float - | Ival.Float_abstract.Bottom -> - CilE.warn_result_nan_infinite with_alarms ; - V.bottom - in - begin match op with - | PlusA -> - binary_float_floats "+." - Ival.Float_abstract.add_float - | MinusA -> - binary_float_floats "-." - Ival.Float_abstract.sub_float - | Mult -> - binary_float_floats "." - Ival.Float_abstract.mult_float - | Div -> - binary_float_floats "/." - Ival.Float_abstract.div_float - | Eq -> - let contains_zero, contains_non_zero = - Ival.Float_abstract.equal_float_ieee f1 f2 - in - V.interp_boolean ~contains_zero ~contains_non_zero - | Ne -> - let contains_non_zero, contains_zero = - Ival.Float_abstract.equal_float_ieee f1 f2 - in - V.interp_boolean ~contains_zero ~contains_non_zero - | Lt -> - V.interp_boolean - ~contains_zero:(Ival.Float_abstract.maybe_le_ieee_float f2 f1) - ~contains_non_zero:(Ival.Float_abstract.maybe_lt_ieee_float f1 f2) - | Le -> - V.interp_boolean - ~contains_zero:(Ival.Float_abstract.maybe_lt_ieee_float f2 f1) - ~contains_non_zero:(Ival.Float_abstract.maybe_le_ieee_float f1 f2) - | Gt -> - V.interp_boolean - ~contains_zero:(Ival.Float_abstract.maybe_le_ieee_float f1 f2) - ~contains_non_zero:(Ival.Float_abstract.maybe_lt_ieee_float f2 f1) - | Ge -> - V.interp_boolean - ~contains_zero:(Ival.Float_abstract.maybe_lt_ieee_float f1 f2) - ~contains_non_zero:(Ival.Float_abstract.maybe_le_ieee_float f2 f1) - | _ -> raise V.Not_based_on_null - end - with V.Not_based_on_null | Ival.F.Nan_or_infinite -> - Value_parameters.warning ~once:true ~current:true - "float operation on address."; - V.join - (V.topify_arith_origin ev1) - (V.topify_arith_origin ev2) - in - state, deps, interpreted_expr - | TInt _ | TPtr (_, _) | _ -> - let interpreted_expr = begin match op with - | PlusPI | IndexPI -> - V.add_untyped (osizeof_pointed typ) ev1 ev2 - | MinusPI -> - V.add_untyped (Int_Base.neg (osizeof_pointed typ)) ev1 ev2 - | PlusA -> - V.add_untyped (Int_Base.inject Int.one) ev1 ev2 - | MinusA | MinusPP -> - let minus_val = V.add_untyped Int_Base.minus_one ev1 ev2 in - if op = MinusA - then minus_val - else (* MinusPP ) - ( try - let size = - Int_Base.project (sizeof_pointed(Cil.typeOf e1)) - in - let size = Int.div size Int.eight in - if Int.is_one size then - minus_val - else - let minus_val = Cvalue_type.V.project_ival minus_val - in - Cvalue_type.V.inject_ival - (Ival.scale_div ~pos:true size minus_val) - with - Int_Base.Error_Top - | Cvalue_type.V.Not_based_on_null - | Not_found -> - V.join - (V.topify_arith_origin ev1) - (V.topify_arith_origin ev2)) - | Mod -> V.c_rem ~with_alarms ev1 ev2 - | Div -> V.div ~with_alarms ev1 ev2 - | Mult -> - V.arithmetic_function ~with_alarms "" Ival.mul ev1 ev2 - | LOr -> - assert false - (* This code makes a strict evaluation: V.interp_boolean - ~contains_zero: (V.contains_zero ev1 && - V.contains_zero ev2) ~contains_non_zero: - (V.contains_non_zero ev1 || V.contains_non_zero - ev2)) - | LAnd -> - assert false - ( This code makes a strict evaluation: - V.interp_boolean ~contains_zero: (V.contains_zero - ev1 || V.contains_zero ev2) ~contains_non_zero: - (V.contains_non_zero ev1 && V.contains_non_zero - ev2)) - | BXor -> V.oper_on_values ~with_alarms "^" Int.logxor ev1 ev2 - | BOr -> - V.bitwise_or ~size:(bitsSizeOf (typeOf e1)) ev1 ev2 - | BAnd -> - ( try - let t = typeOf e1 in - let size = bitsSizeOf t in - let signed = is_signed_int_enum_pointer t in - V.bitwise_and ~size ~signed ev1 ev2 - with SizeOfError _ -> - V.join - (V.topify_arith_origin ev1) - (V.topify_arith_origin ev2)) - - | Eq | Ne | Ge | Le | Gt | Lt -> - let warn, ev1, ev2 = check_comparable ev1 ev2 in - if warn - then begin - CilE.warn_pointer_comparison with_alarms; - end; - if warn && Value_parameters.UndefinedPointerComparisonPropagateAll.get () - then V.zero_or_one - else - let f = match op with - | Eq -> V.check_equal true - | Ne -> V.check_equal false - | Ge -> V.comparisons ">=" V.do_ge - | Le -> V.comparisons "<=" V.do_le - | Gt -> V.comparisons ">" V.do_gt - | Lt -> V.comparisons "<" V.do_lt - | _ -> assert false - in - f ev1 ev2 - | Shiftrt -> - begin try - let signed = is_signed_int_enum_pointer typ in - V.shift_right - ~with_alarms ~size:(bitsSizeOf typ) ~signed - ev1 - ev2 - with SizeOfError _ -> - ( match with_alarms.CilE.imprecision_tracing with - | CilE.Aignore -> () - | CilE.Acall f -> f () - | CilE.Alog -> - Value_parameters.result - "shifting value of unknown size"); - V.top ( TODO: topify ... ) - end - | Shiftlt -> - begin try - V.shift_left ~with_alarms ~size:(bitsSizeOf typ) ev1 ev2 - with SizeOfError _ -> - ( match with_alarms.CilE.imprecision_tracing with - | CilE.Aignore -> () - | CilE.Acall f -> f () - | CilE.Alog -> - Value_parameters.result - "shifting value of unknown size"); - V.top ( TODO: topify ... ) - end - end - in - ( Warn if overflow in a signed int binop ) - let interpreted_expr = - match op with - Shiftlt|Mult|MinusPP|MinusPI|IndexPI| - PlusPI|PlusA|Div|Mod|MinusA -> - handle_signed_overflow - ~with_alarms - syntactic_context - typ - e - interpreted_expr - | _ -> interpreted_expr - in - state, deps, interpreted_expr - end - end - | _ -> assert false - -and eval_expr_with_deps_state - ~with_alarms deps (state : Relations_type.Model.t) e = - let state, deps, expr = - let orig_expr = Cil.stripInfo e in - match orig_expr.enode with - | Info _ -> assert false - | Const v -> - let r = - begin match v with - | CInt64 (i,k,_s) -> - V.inject_int ( - if isSigned k - then Int.of_int64 i - else ( For 64 bits type we need to reinterpret the sign ) - let s = Printf.sprintf "%Lu" i in - Int.of_string s) - | CChr c -> - (match charConstToInt c with - | CInt64 (i,_,_) -> V.inject_int (Int.of_int64 i) - | _ -> assert false) - | CReal (f, _fsize, _) -> - Value_parameters.result ~once:true - "float support is experimental"; - let f = Ival.F.of_float f in - let overflow, af = - try - let o, af = Ival.Float_abstract.inject_r f f in - o, V.inject_ival (Ival.inject_float af) - with Ival.Float_abstract.Bottom -> - Value_parameters.result ~current:true - "Floating-point literal (or constant expression) is not finite. This path is assumed to be dead."; - true, V.bottom - in - if overflow - then Value_parameters.result "overflow in constant: assert(Ook);"; - af - | CWStr _ -> - Value_parameters.result "approximation because of a wide string"; - ( TODO ) V.top_int - | CStr s -> - V.inject (Base.create_string s) Ival.zero - | CEnum {eival = e} -> - let _,_, r = - eval_expr_with_deps_state ~with_alarms deps state e - in - r - end - in - state, deps, r - | BinOp _ -> - eval_BinOp ~with_alarms orig_expr deps state - | Lval lv -> - eval_lval ~conflate_bottom:true ~with_alarms deps state lv - | AddrOf v | StartOf v -> - let state, deps, r = - lval_to_loc_with_offset_deps_only_option ~with_alarms ?deps state v - in - state, deps, loc_to_loc_without_size r - - | CastE (typ, e) -> - let deps, evaled_expr = - eval_expr_with_deps ~with_alarms deps state e - in - let src_typ = unrollType (typeOf e) in - let dest_type = unrollType typ in - let r = do_promotion ~with_alarms ~dest_type ~src_typ evaled_expr e in - state, deps, r - - - | SizeOf typ -> - let r = - try V.inject_ival - (Ival.inject_singleton ((Int.of_int ((bitsSizeOf typ) / 8)))) - with SizeOfError _ -> - error "cannot interpret sizeof(incomplete type)"; - V.top_int - in - state, deps, r - | SizeOfE e -> - let typ = typeOf e in - let r = - try V.inject_ival - (Ival.inject_singleton ((Int.of_int ((bitsSizeOf typ) / 8)))) - with SizeOfError _ -> - error "cannot interpret sizeof(incomplete type)"; - V.top_int - in - state, deps, r - - | UnOp (LNot, e, _) -> - ( TODO: on float, LNot is equivalent to == 0.0 ) - let deps, expr = eval_expr_with_deps ~with_alarms deps state e in - CilE.set_syntactic_context (CilE.SyBinOp (Eq, Cil.zero ~loc:e.eloc, e)); - let warn, _, expr = - check_comparable V.singleton_zero expr - in - if warn - then begin - CilE.warn_pointer_comparison with_alarms; - end; - let r = - if warn && - Value_parameters.UndefinedPointerComparisonPropagateAll.get () - then V.zero_or_one - else - if - let t1 = typeOf e in isIntegralType t1 || isPointerType t1 - then - V.interp_boolean - ~contains_zero:(V.contains_non_zero expr) - ~contains_non_zero:(V.contains_zero expr) - else V.zero_or_one - in - state, deps,r - | UnOp (Neg, e, t) -> - let t = unrollType t in - let deps, expr = eval_expr_with_deps ~with_alarms deps state e in - let syntactic_context = CilE.SyUnOp orig_expr in - CilE.set_syntactic_context syntactic_context; - ( match t with TFloat _ -> - let result = - try - let v = V.project_ival expr in - let f = - Ival.project_float v - in - V.inject_ival - (Ival.inject_float (Ival.Float_abstract.neg_float f)) - with - V.Not_based_on_null -> - begin match with_alarms.CilE.others with - CilE.Aignore -> () - | CilE.Acall f -> f() - | CilE.Alog -> - Value_parameters.warning ~once:true ~current:true - "converting address to float: assert(TODO)" - end; - V.topify_arith_origin expr - | Ival.Float_abstract.Nan_or_infinite -> - begin match with_alarms.CilE.others with - CilE.Aignore -> () - | CilE.Acall f -> f() - | CilE.Alog -> - Value_parameters.warning ~once:true ~current:true - "converting value to float: assert (TODO)" - end; - V.top_float - in - state, deps, result - | _ -> - let result = - try - let v = V.project_ival expr in - V.inject_ival (Ival.neg v) - with V.Not_based_on_null -> V.topify_arith_origin expr - in - let result = - handle_signed_overflow ~with_alarms - syntactic_context t orig_expr result - in - state, deps, result) - - | UnOp (BNot, e, _) -> - let deps, expr = eval_expr_with_deps ~with_alarms deps state e in - CilE.set_syntactic_context (CilE.SyUnOp e); - let result = - try - let v = V.project_ival expr in - V.inject_ival - (Ival.apply_set_unary "~" Int.lognot v) - with V.Not_based_on_null -> V.topify_arith_origin expr - in - state, deps, result - | AlignOfE _|AlignOf _|SizeOfStr _ - -> - Value_parameters.result - "C construct alignof or sizeof string not precisely handled"; - state, deps, V.top_int - in - let r = - if hasAttribute "volatile" (typeAttrs (typeOf e)) - && not (Cvalue_type.V.equal Cvalue_type.V.bottom expr) - then V.top_int - else - expr - in - let state,r_ptr = PtrRelational.eval_expr ~with_alarms state e in - let r = Cvalue_type.V.narrow r_ptr r in - let typ = typeOf e in - ( let r = - handle_signed_overflow ~with_alarms (CilE.SyUnOp e) typ e r - in TODO ) - let r = do_cast ~with_alarms typ r in - state, deps, r - -and eval_expr_with_deps_state_subdiv ~with_alarms deps - (state : Relations_type.Model.t) e = - let ((state_without_subdiv, deps_without_subdiv, result_without_subdiv) as result) = - eval_expr_with_deps_state ~with_alarms deps - (state : Relations_type.Model.t) e - in - let subdivnb = Value_parameters.Subdivide_float_in_expr.get() in - if subdivnb=0 - then result - else if not (Locations.Location_Bytes.is_included result_without_subdiv Locations.Location_Bytes.top_int) - then begin - Value_parameters.debug ~level:2 - "subdivfloatvar: expression has an address result"; - result - end - else - let compare_min, compare_max = - if Locations.Location_Bytes.is_included result_without_subdiv Locations.Location_Bytes.top_float - then begin - Value_parameters.debug ~level:2 - "subdivfloatvar: optimizing floating-point expression %a=%a" - !d_exp e - Locations.Location_Bytes.pretty result_without_subdiv; - Cvalue_type.V.compare_min_float, Cvalue_type.V.compare_max_float - end - else begin - Value_parameters.debug ~level:2 - "subdivfloatvar: optimizing integer expression %a=%a" - !d_exp e - Locations.Location_Bytes.pretty result_without_subdiv; - Cvalue_type.V.compare_min_int, Cvalue_type.V.compare_max_int - end - in - let vars = - get_influential_vars ~with_alarms:CilE.warn_none_mode state e - in - Value_parameters.debug ~level:2 "subdivfloatvar: variable list=%a" - (Pretty_utils.pp_list Locations.pretty) - vars; - let rec try_sub vars = - match vars with - [] | [ _ ] -> - result - | v :: tail -> - try - if not (List.exists (fun x -> Locations.loc_equal v x) tail) - then raise Too_linear; - let v_value = - Relations_type.Model.find - ~conflate_bottom:true - ~with_alarms:CilE.warn_none_mode - state - v - in - Value_parameters.debug ~level:2 - "subdivfloatvar: considering optimizing variable %a (value %a)" - Locations.pretty v Cvalue_type.V.pretty v_value; - if not (Locations.Location_Bytes.is_included - v_value - Locations.Location_Bytes.top_float) - then raise Too_linear; - - let working_list = ref [ (v_value, result_without_subdiv) ] in - let had_bottom = ref false in - let subdiv_for_bound better_bound = - let rec insert_subvalue_in_list (_, exp_value as p) l = - match l with - [] -> [p] - | (_, exp_value1 as p1) :: tail -> - if better_bound exp_value1 exp_value >= 0 - then p :: l - else p1 :: (insert_subvalue_in_list p tail) - in - let exp_subvalue subvalue l = - let substate = - ( FIXME: should be relation-aware primitive ) - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - v - subvalue - in - let subexpr = eval_expr ~with_alarms substate e in - Value_parameters.debug ~level:2 - "subdivfloatvar: computed var=%a expr=%a" - V.pretty subvalue - V.pretty subexpr; - if Cvalue_type.V.is_bottom subexpr - then begin - had_bottom := true; - l - end - else - insert_subvalue_in_list (subvalue, subexpr) l - in - let subdiv l = - match l with - [] -> - Value_parameters.debug - "subdivfloatvar: all reduced to bottom!!"; - raise Ival.Can_not_subdiv - | (value, _exp_value) :: tail -> - let (subvalue1, subvalue2) = - Cvalue_type.V.subdiv_float_interval value - in - let s = exp_subvalue subvalue1 tail - in - exp_subvalue subvalue2 s - in - try - for i = 1 to subdivnb do - working_list := subdiv !working_list; - done - with Ival.Can_not_subdiv -> () - in - subdiv_for_bound compare_min ; - ( sort working_list in decreasing order - on the upper bounds of exp_value ) - let comp_exp_value (_value1,exp_value1) (_value2,exp_value2) = - compare_max exp_value1 exp_value2 - in - working_list := List.sort comp_exp_value !working_list ; - if Value_parameters.debug_atleast 2 then - List.iter - (function (x, e) -> - Value_parameters.debug - "subdivfloatvar: elements of list max %a %a" - V.pretty x V.pretty e) - !working_list; - subdiv_for_bound compare_max ; - let working_list = !working_list in - if Value_parameters.debug_atleast 2 then - List.iter - (function (x, e) -> - Value_parameters.debug - "subdivfloatvar: elements of final list %a %a" - V.pretty x V.pretty e) - working_list; - let reduced_state, optimized_exp_value = - if !had_bottom - then - let reduced_var, optimized_exp_value = - List.fold_left - (fun (accv,acce) (value, exp_value) -> - Cvalue_type.V.join value accv, - Cvalue_type.V.join exp_value acce) - (Cvalue_type.V.bottom, - Cvalue_type.V.bottom) - working_list - in - ( FIXME: should be relation-aware primitive ) - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - v - reduced_var, - optimized_exp_value - else - state_without_subdiv, - List.fold_left - (fun acc (_value, exp_value) -> - Cvalue_type.V.join exp_value acc) - Cvalue_type.V.bottom - working_list - in - reduced_state, deps_without_subdiv, optimized_exp_value - with Not_less_than | Too_linear -> - try_sub tail - in - try_sub vars - -and eval_lval_using_main_memory ~conflate_bottom ~with_alarms - deps (state:Relations_type.Model.t) lv - = - let state,deps,loc = - lval_to_loc_deps_option ~with_alarms ?deps state lv - ~reduce_valid_index:(Parameters.SafeArrays.get ()) - in - CilE.set_syntactic_context (CilE.SyMem lv); - let result = - Relations_type.Model.find - ~conflate_bottom - ~with_alarms state loc in - ( TODO: move into Model.find ) - let valid_loc = Locations.valid_part loc in - let state = - if Location_Bits.equal loc.Locations.loc valid_loc.Locations.loc - then state - else begin - match lv with - Mem (exp_mem),NoOffset -> - let lv_mem_plus_list = - find_lv_plus ~with_alarms:CilE.warn_none_mode state exp_mem - in - let treat_lv_mem_plus (lv_mem, plus) state = - let loc_mem = - lval_to_loc ~with_alarms:CilE.warn_none_mode state lv_mem - in - if Location_Bits.is_relationable loc_mem.Locations.loc - then - let new_val = - Location_Bytes.location_shift - (Ival.neg plus) - (loc_bits_to_loc_bytes valid_loc.loc) - in - Relations_type.Model.reduce_binding - state loc_mem new_val - else state - in - List.fold_right treat_lv_mem_plus lv_mem_plus_list state - | _ -> state - end - in - (match with_alarms.CilE.imprecision_tracing with - | CilE.Aignore -> () - | CilE.Acall f -> f () - | CilE.Alog -> warn_lval_read lv loc result); - let new_deps = - match deps with - | None -> None - | Some deps -> Some (Zone.join deps (valid_enumerate_bits loc)) - in - state, new_deps, result - -and eval_lval ~conflate_bottom ~with_alarms deps state (base,offset as lv) = - let state, deps, result_from_main_memory = - eval_lval_using_main_memory ~conflate_bottom ~with_alarms deps state lv - in - let find_loc_mem sub_lv offs = - try - let loc = lval_to_loc ~with_alarms state sub_lv in - let size = sizeof_lval lv in - CilE.set_syntactic_context (CilE.SyMem lv); - Relations_type.Model.find_mem loc size offs state - with Relations_type.Use_Main_Memory -> - result_from_main_memory - in - let result = match base with - | Mem({enode = Lval sub_lv} as e) when UseRelations.get () -> - let typ = typeOf e in - begin try - let _, _, offs = - eval_offset ~reduce_valid_index:(Parameters.SafeArrays.get ()) - ~with_alarms None typ state offset - in - find_loc_mem sub_lv offs - with - Offset_not_based_on_Null _ -> - result_from_main_memory - end - | Mem({enode = BinOp((PlusPI|IndexPI|MinusPI as op), - {enode = Lval sub_lv} , - e2,_)} - as e) - when UseRelations.get () -> - begin - let e2 = eval_expr ~with_alarms state e2 in - let typ = typeOf e in - try - let ival = Cvalue_type.V.project_ival e2 in - let ival = if op=MinusPI then Ival.neg ival else ival in - let _, _, offs = - eval_offset ~reduce_valid_index:(Parameters.SafeArrays.get ()) - ~with_alarms None typ state offset in - let offs = ( convert to bits ) - Ival.add - (Ival.scale - (Int_Base.project (sizeof_pointed typ)) - ival) - offs - in - let result = find_loc_mem sub_lv offs in - result - with - | Offset_not_based_on_Null _ - | Int_Base.Error_Top - | Cvalue_type.V.Not_based_on_null -> result_from_main_memory - end - | _e -> - result_from_main_memory - in - let result_inter = Cvalue_type.V.narrow result_from_main_memory result in - state, deps, result_inter - -and eval_offset ~reduce_valid_index ~with_alarms deps typ state offset = - match offset with - | NoOffset -> - state, deps, Ival.singleton_zero - | Index (exp,remaining) -> - let typ_pointed,array_size = match (unrollType typ) with - | TArray (t,size,_,_) -> t, size - | TPtr(t,_) -> - (match unrollType t with - | TArray (t,size,_,_) -> t,size ( pointer to start of an array ) - | _ -> - error "Got type '%a'" !Ast_printer.d_type t; - assert false) - | t -> - error "Got type '%a'" !Ast_printer.d_type t; - assert false - in - let state, deps, current = - eval_expr_with_deps_state ~with_alarms deps state exp - in - if V.is_bottom current - then Relations_type.Model.bottom, (Some Zone.bottom), Ival.bottom - else - let state, offset = - try - let v = V.project_ival current in - let state, v = - if reduce_valid_index then - try - let array_siz = lenOfArray64 array_size in - let new_v = - Ival.narrow - (Ival.inject_range - (Some Int.zero) - (Some (Int.of_int64 (Int64.pred array_siz)))) - v - in - let new_state = - if Ival.equal new_v v - then state - else begin - begin - match with_alarms.CilE.others with - | CilE.Aignore -> () - | CilE.Acall f -> f () - | CilE.Alog -> - CilE.set_syntactic_context - (CilE.SyBinOp - (IndexPI, - exp, - Cilutil.out_some array_size)); - CilE.warn_index with_alarms "accessing" - end; - state ( TODO : if the index is a variable, reduce *) - end - in - new_state, new_v - with LenOfArray -> state, v - else state, v - in - state, v - with V.Not_based_on_null -> - let deps, offset = - topify_offset - ~with_alarms - deps - state - (Cvalue_type.V.topify_arith_origin current) - remaining - in - raise (Offset_not_based_on_Null (deps,offset)) - in - let state, deps, r = - eval_offset ~reduce_valid_index ~with_alarms - deps typ_pointed state remaining - in - let offset = Ival.scale_int64base (sizeof typ_pointed) offset in - state, deps, Ival.add offset r - | Field (fi,remaining) -> - let current,_ = bitsOffset typ (Field(fi,NoOffset)) in - let state, deps, r = - eval_offset ~reduce_valid_index ~with_alarms - deps - fi.ftype - state - remaining - in - state, deps, Ival.add (Ival.of_int current) r -and topify_offset ~with_alarms deps state acc offset = - match offset with - | NoOffset -> deps,acc - | Field (_fi,remaining) -> topify_offset ~with_alarms deps state acc remaining - | Index (exp,remaining) -> - let deps, loc_index = eval_expr_with_deps ~with_alarms deps state exp in - let acc = Location_Bytes.join - (Cvalue_type.V.topify_arith_origin loc_index) - acc - in - topify_offset ~with_alarms deps state acc remaining - -(** raises [Reduce_to_bottom] and never returns [Relations_type.Model.bottom]) -let rec eval_cond ~with_alarms state cond = - ( Do not reduce anything if the cond is volatile. - (This test is dumb because the cond may contain volatile l-values - without the "volatile" attribute appearing at toplevel. pc 2007/11) ) - if hasAttribute "volatile" (typeAttr (typeOf cond.exp)) then state - else - let eval_symetric_int positive binop cond_expr value = - match positive,binop with - | false, Eq | true, Ne -> V.diff_if_one value cond_expr - | true, Eq | false, Ne -> V.narrow value cond_expr - | _,_ -> value - in - let eval_symetric_float = eval_symetric_int in - let eval_antisymetric_int ~typ_loc:_ positive binop cond_expr value = - try match positive,binop with - | true, Le | false, Gt -> - V.filter_le value ~cond_expr - | true, Ge | false, Lt -> - V.filter_ge value ~cond_expr - | false, Le | true, Gt -> - V.filter_gt value ~cond_expr - | false, Ge | true, Lt -> - V.filter_lt value ~cond_expr - | _,_ -> value - with V.Error_Bottom -> V.bottom - in - let eval_antisymetric_float ~typ_loc positive binop cond_expr value = - try match positive,binop with - | true, Le | false, Gt -> - V.filter_le_float value ~cond_expr - | true, Ge | false, Lt -> - V.filter_ge_float value ~cond_expr - | false, Le | true, Gt -> - V.filter_gt_float (Value_parameters.AllRoundingModes.get ()) - ~typ_loc value ~cond_expr - | false, Ge | true, Lt -> - V.filter_lt_float (Value_parameters.AllRoundingModes.get ()) - ~typ_loc value ~cond_expr - | _,_ -> value - with V.Error_Bottom -> V.bottom - in - let eval_as_exact_loc state e = - try - let lv = find_lv ~with_alarms state e in - let loc = lval_to_loc ~with_alarms state lv in - if not (valid_cardinal_zero_or_one loc) - then raise Not_an_exact_loc; - let typ = typeOfLval lv in - let value_for_loc = - Relations_type.Model.find ~conflate_bottom:true - ~with_alarms state loc - in - let value_for_loc2 = - do_cast - ~with_alarms - ( Using (typeOf e) caused imprecisions with - the condition char c; ... if (c>0) - being transformed in if (((int)c)>0) by Cil. ) - typ - value_for_loc - in - if Cvalue_type.V.has_sign_problems value_for_loc && - not (Cvalue_type.V.equal value_for_loc value_for_loc2) - then begin -( Value_parameters.warning ~current:true "oh: %a %a %a@." - Locations.pretty loc - V.pretty value_for_loc - V.pretty value_for_loc2; ) - raise Not_an_exact_loc; - end; - loc, value_for_loc2, typ - with Cannot_find_lv -> - raise Not_an_exact_loc - in - let rec aux cond state = - match cond.positive,cond.exp.enode with - | _positive, BinOp ((Le|Ne|Eq|Gt|Lt|Ge as binop), exp1, exp2, _typ) -> - let eval_eq_ineq eval_symetric eval_antisymetric = - let loc1 = ref None in - let loc2 = ref None in - let result1 = - try - let left_loc,value_for_loc,typ_loc = - eval_as_exact_loc state exp1 - in - loc1 := Some left_loc; - let cond_expr = eval_expr ~with_alarms state exp2 in - let v_sym = - eval_symetric cond.positive binop cond_expr value_for_loc - in - let v_asym = - eval_antisymetric ~typ_loc - cond.positive binop cond_expr v_sym - in - if V.equal v_asym V.bottom then raise Reduce_to_bottom; - if V.equal v_asym value_for_loc - then state - else - Relations_type.Model.reduce_binding state left_loc v_asym - with Not_an_exact_loc -> state - in - let result2 = try - let right_loc,value_for_loc,typ_loc = - eval_as_exact_loc result1 exp2 - in - loc2 := Some right_loc; - let cond_expr = eval_expr ~with_alarms result1 exp1 - in - let v_sym = eval_symetric - cond.positive binop cond_expr value_for_loc - in - let v_asym = eval_antisymetric - ~typ_loc - cond.positive - (match binop with Gt -> Lt | Lt -> Gt | Le -> Ge | Ge -> Le - | _ -> binop) - cond_expr - v_sym - in - if V.equal v_asym V.bottom then raise Reduce_to_bottom; - if V.equal v_asym value_for_loc - then result1 - else - Relations_type.Model.reduce_binding result1 right_loc v_asym - with Not_an_exact_loc -> result1 - in - let result3 = - begin match (cond.positive, binop), !loc1, !loc2 with - ((true,Eq)|(false, Ne)), Some(left_loc), Some(right_loc) -> - Relations_type.Model.reduce_equality - result2 left_loc right_loc - | _ -> result2 - end - in - result3 - in - let t1 = unrollType (typeOf exp1) in - if isIntegralType t1 || isPointerType t1 - then - eval_eq_ineq eval_symetric_int eval_antisymetric_int - else - eval_eq_ineq eval_symetric_float eval_antisymetric_float - | true, BinOp (LAnd, exp1, exp2, _) - | false, BinOp (LOr, exp1, exp2, _) -> - let new_state = aux {cond with exp = exp1} state in - let result = aux {cond with exp = exp2} new_state in - result - | false, BinOp (LAnd, exp1, exp2, _) - | true, BinOp (LOr, exp1, exp2, _) -> - let new_v1 = try aux {cond with exp = exp1} state - with Reduce_to_bottom -> Relations_type.Model.bottom - in let new_v2 = try aux {cond with exp = exp2} state - with Reduce_to_bottom -> Relations_type.Model.bottom - in - Relations_type.Model.join new_v1 new_v2 - - | _, UnOp(LNot,exp,_) -> - aux - { positive = not cond.positive; - exp = exp; } - state - | _, Lval _ - when let t = typeOf cond.exp in - isIntegralType t || isPointerType t - -> - ( "if (c)" is equivalent to "if(!(c==0))" ) - (try - let loc,value_for_loc,_ = eval_as_exact_loc state cond.exp in - let new_value = - eval_symetric_int (not cond.positive) - Eq - (V.inject_ival Ival.singleton_zero) - value_for_loc - in - if V.equal new_value V.bottom then - raise Reduce_to_bottom - else - Relations_type.Model.reduce_binding - state loc new_value - with Not_an_exact_loc -> state) - | _ -> state - in - let result = - aux cond state - in - let condition_may_still_be_true_in_state env = - let cond_interp = eval_expr ~with_alarms env cond.exp in - (not cond.positive || V.contains_non_zero cond_interp) && - (cond.positive || V.contains_zero cond_interp) - in - if (not (Relations_type.Model.equal result state)) && - (not (condition_may_still_be_true_in_state result)) - then raise Reduce_to_bottom; - let is_enumerable v = - let v_interp = - Relations_type.Model.find ~conflate_bottom:true ~with_alarms result v - in - ignore (Location_Bytes.cardinal_less_than v_interp 7); - v_interp - in - let rec enumerate_one_var l = - match l with - | [] -> raise Not_found - | v::t -> - try - let v_interp = is_enumerable v in - v,v_interp,t - with Abstract_interp.Not_less_than -> - enumerate_one_var t - in - let invert_cond vl = - try - let v1,v_interp1, _tail = enumerate_one_var vl in - let f one_val acc = - ( interpret cond in an environment where v -> one_val - ) - let env = - Relations_type.Model.reduce_binding - result v1 one_val - in - if condition_may_still_be_true_in_state env - then begin - ( stays ) - Location_Bytes.join one_val acc - end - else begin - ( goes ) - acc - end - in - let new_v_interp = - Location_Bytes.fold_enum - ~split_non_enumerable:2 - f v_interp1 Location_Bytes.bottom - in - let state_value = - if V.equal new_v_interp V.bottom - then raise Reduce_to_bottom - else Relations_type.Model.reduce_binding result v1 new_v_interp - in - state_value - with Not_found -> result - in - let result1 = - invert_cond (get_influential_vars ~with_alarms result cond.exp) - in - if not (Relations_type.Model.is_reachable result1) - then raise Reduce_to_bottom - else result1 - -exception Ignore - ( raised to completely ignore an instruction or statement ) - -( See bug report fs#182 ) -let resolv_func_vinfo ~with_alarms deps state funcexp = - match funcexp.enode with - | Lval (Var vinfo,NoOffset) -> - deps, Kernel_function.Hptset.singleton (Globals.Functions.get vinfo) - | Lval (Mem v,NoOffset) -> - let deps, loc = eval_expr_with_deps ~with_alarms deps state v in - let fundecs = List.fold_left - (fun acc varid -> - match varid with - | Base.String (_,_) -> - Value_parameters.warning ~once:true ~current:true - "Function pointer call at string position in memory: ignoring this particular value: assert(TODO)"; - acc - | Base.Null -> - Value_parameters.warning ~once:true ~current:true - "Function pointer call at absolute position in memory: ignoring this particular value: assert(TODO)"; - acc - | Base.Cell_class _ -> - Value_parameters.warning ~once:true ~current:true - "Function pointer call at memory cell class: ignoring this particular value: assert(TODO)"; - acc - | Base.Var (v,_) | Base.Initialized_Var (v,_) -> - Kernel_function.Hptset.add (Globals.Functions.get v) acc - ) - Kernel_function.Hptset.empty - (try - Location_Bytes.get_keys_exclusive Ival.zero loc - with Location_Bytes.Not_all_keys -> - Value_parameters.warning ~once:true ~current:true - "Function pointer call is completely unknown: assuming no effects: assert(TODO)"; - raise Leaf) - in - ( (ignore (Errormsg.log - "Function pointer resolved to %d functions.\n" - (List.length fundecs)); true);*) - deps, fundecs - | _ -> - assert false - -let make_well hidden_base state loc = - let size = Bit_utils.max_bit_size () in - let well = Cvalue_type.V.inject_top_origin - Origin.Well - (Cvalue_type.V.Top_Param.O.singleton hidden_base) - in - let well_loc = - Locations.make_loc - (Location_Bits.inject hidden_base Ival.zero) - (Int_Base.inject size) - in - let state_with_well = - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - well_loc - well - in - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state_with_well - loc - well - -let create_hidden_base - validity_from_type ~hidden_var_name ~name_desc pointed_typ = - let hidden_var = - makeGlobalVar ~generated:false ~logic:true hidden_var_name pointed_typ - in - Globals.Vars.add_decl hidden_var; - hidden_var.vdescr <- Some name_desc; - let validity = - if validity_from_type - then begin - match Base.validity_from_type hidden_var with - | Base.Known (a,b) - when not (Value_parameters.AllocatedContextValid.get ()) -> - Base.Unknown (a,b) - | (Base.All | Base.Unknown _ | Base.Known _) as s -> s - | Base.Periodic _ -> assert false - end - else Base.Unknown (Int.zero,Bit_utils.max_bit_address ()) - in - let hidden_base = Base.create_logic hidden_var validity - in - hidden_base - -(** [initialize_var_using_type varinfo state] uses the type of [varinfo] - to create an initial value in [state]. ) -let initialize_var_using_type varinfo state = - CurrentLoc.set varinfo.vdecl; - let initializing_formal = not varinfo.vglob in - let rec add_offsetmap depth v name_desc name typ offset_orig typ_orig state = - let typ = Cil.unrollType typ in - let loc = loc_of_typoffset v typ_orig offset_orig in - let must_initialize = - initializing_formal || - (not (hasAttribute "const" (typeAttrs typ))) || - (Cvalue_type.V.equal - (Relations_type.Model.find - ~conflate_bottom:true ~with_alarms:CilE.warn_none_mode - state loc) - Cvalue_type.V.bottom) - in - if not must_initialize - ( if we do not have an initializer for this const, we generate - a formal constant ) - then state else - match typ with - | TInt _ | TEnum (_, _)-> - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - loc - Cvalue_type.V.top_int - | TFloat _ -> - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - loc - Cvalue_type.V.top_float - | TFun _ -> - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - loc - (Cvalue_type.V.top_leaf_origin ()) - | TPtr (typ, _) as full_typ - when depth <= Value_parameters.AutomaticContextMaxDepth.get () -> - let attr = typeAttr full_typ in - let context_max_width = - Value_parameters.AutomaticContextMaxWidth.get () - in - if not (isVoidType typ) && not (isFunctionType typ) then - let i = - match findAttribute "arraylen" attr with - | [AInt i] -> i - | _ -> context_max_width - in - let pointed_typ = - TArray(typ, - Some (integer ~loc:varinfo.vdecl i), - empty_size_cache (), - []) - in - let hidden_var_name = - Cabs2cil.fresh_global ("S_" ^ name) - in - let name_desc = ""^name_desc in - let hidden_base = - create_hidden_base - true - ~hidden_var_name - ~name_desc - pointed_typ - in - let state = - add_offsetmap - (depth + 1) - hidden_base - name_desc - hidden_var_name - pointed_typ - NoOffset - pointed_typ - state - in - let value = Cvalue_type.V.inject hidden_base (Ival.zero) - in - let value = - if Value_parameters.AllocatedContextValid.get () - then value - else Cvalue_type.V.join Cvalue_type.V.singleton_zero value - in - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - loc - value - else - let hidden_var_name = - Cabs2cil.fresh_global ("S_" ^ name) - in - let name_desc = ""^name_desc in - let hidden_base = - create_hidden_base - false - ~hidden_var_name - ~name_desc - typ - in - make_well hidden_base state loc - - | TArray (typ, len, _, _) -> - begin try - let size = lenOfArray len in - let state = ref state in - let typ = Cil.unrollType typ in - let treat_index (i : int) = - let offset = - addOffset - (Index (integer ~loc:varinfo.vdecl i, NoOffset)) - offset_orig - in - let name = (string_of_int i) ^"_"^ name in - let name_desc = name_desc ^ "[" ^ (string_of_int i) ^ "]" in - let s = - add_offsetmap depth v - name_desc name typ - offset typ_orig !state - in - state := s; - let loc = loc_of_typoffset v typ_orig offset in - let r_offsetmap = - Relations_type.Model.copy_offsetmap - ~with_alarms:CilE.warn_none_mode - loc s - in - match r_offsetmap with - Some r_offsetmap -> r_offsetmap - | None -> assert false - in - let max_precise_size = - Value_parameters.AutomaticContextMaxWidth.get () - in - if size <= max_precise_size - then - for i = 0 to pred size do - ignore (treat_index i) - done - else begin -( Format.printf "ST %a: size=%d max_precise_size=%d offset=%a@." - Base.pretty v - size - max_precise_size - (!d_offset) offset_orig ; ) - let vv = ref None in - for i = 0 to pred max_precise_size do -( Format.printf "IT %d@.%a@." - i - Relations_type.Model.pretty !state; ) - let r = treat_index i in - vv := - Some - ( match !vv with - None -> r - | Some vv -> snd (Cvalue_type.V_Offsetmap.join r vv)) - done; - ( match !vv with - None -> assert false - | Some vv -> -( Format.printf "EN %a@." - Cvalue_type.V_Offsetmap.pretty vv; ) - for i = max_precise_size to pred size do - let offset = - addOffset - (Index (integer ~loc:varinfo.vdecl i, NoOffset)) - offset_orig - in - let loc = loc_of_typoffset v typ_orig offset in - let size = - try - Int_Base.project loc.size - with - | Int_Base.Error_Top - | Int_Base.Error_Bottom -> - assert false - in - state := - Relations_type.Model.paste_offsetmap - vv loc.loc Int.zero size !state - done); - end; - !state - with LenOfArray -> - Value_parameters.result ~once:true ~current:true - "could not find a size for array"; - state - end - | TComp ({cstruct=true;} as compinfo, _, _) -> ( Struct ) - let treat_field (next_offset,state) field = - let new_offset = Field (field, NoOffset) in - let offset = - addOffset - new_offset - offset_orig - in - let field_offset,field_width = bitsOffset typ_orig offset in - let state = - if field_offset>next_offset then ( padding bits needs filling) - let loc = make_loc - (Location_Bits.inject v (Ival.of_int next_offset)) - (Int_Base.inject (Int.of_int (field_offset-next_offset))) - in - Relations_type.Model.add_binding_unspecified - state - loc - else state - in - field_offset+field_width, - add_offsetmap - depth - v - (name_desc ^ "." ^ field.fname) - (field.fname^"_"^name) - field.ftype - offset - typ_orig - state - in - begin try - let boff,bwidth = bitsOffset typ_orig offset_orig in - let last_offset,state= List.fold_left - treat_field - (boff,state) - compinfo.cfields - in - if last_offset<(boff+bwidth) then ( padding at end of struct) - let loc = make_loc - (Location_Bits.inject v (Ival.of_int last_offset)) - (Int_Base.inject (Int.of_int (boff+bwidth-last_offset))) - in - Relations_type.Model.add_binding_unspecified - state - loc - else state - with Cil.SizeOfError _ -> state - end - | TComp ({cstruct=false}, _, _) when - is_fully_arithmetic typ - -> ( Union of arithmetic types ) - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - loc - Cvalue_type.V.top_int - - | TPtr _ when Value_parameters.AllocatedContextValid.get () -> - ( deep pointers map to NULL in this case ) - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - state - loc - Cvalue_type.V.singleton_zero - - | TBuiltin_va_list _ | TComp _ | TVoid _ | TPtr _ -> - ( variable arguments or union with non-arithmetic type - or deep pointers ) - - ( first create a new varid and offsetmap for the - "hidden location" ) - let hidden_var_name = - Cabs2cil.fresh_global ("WELL_"^name) - in - let hidden_var = - makeGlobalVar ~logic:true hidden_var_name charType - in - hidden_var.vdescr <- Some (name_desc^"_WELL"); - let hidden_base = - Base.create_logic - hidden_var - (Base.Known (Int.zero,Bit_utils.max_bit_address ())) - in - make_well hidden_base state loc - | TNamed (_, _) -> assert false - in - add_offsetmap - 0 - (Base.create_varinfo varinfo) - varinfo.vname varinfo.vname varinfo.vtype NoOffset varinfo.vtype state - -let initial_state_only_globals = - let module S = - State_builder.Option_ref - (Relations_type.Model) - (struct - let name = "only_globals" - let dependencies = - [ Ast.self; Parameters.LibEntry.self; Parameters.MainFunction.self ] - let kind = `Internal - end) - in - function () -> - let compute () = - Value_parameters.debug ~level:2 "Computing globals values"; - let state = ref Relations_type.Model.empty_map in - let complete_init last_bitsoffset typ _l lval = - ( Now process the non initialized bits defaulting to 0 ) - begin try - let size_to_add, offset = - bitsSizeOf typ - last_bitsoffset, - Ival.inject_singleton (Int.of_int last_bitsoffset) - in - assert (size_to_add >= 0); - if size_to_add <> 0 then - let loc = - match lval with - | Var vinfo, _ -> - let base = Base.create_varinfo vinfo in - let size_to_add = (Int.of_int size_to_add) in - let offset, size = - match Base.validity base with - Base.Periodic (mn, _mx, p) when Int.ge size_to_add p -> - Ival.inject_singleton mn, p - | _ -> offset, size_to_add - in - let loc = - Location_Bits.inject base offset - in - let loc = make_loc loc (Int_Base.inject size) in -( Format.printf "loc for final zeroes %a@." - Locations.pretty loc; ) - loc - | _ -> error "Whacky initializer ? Please report."; - assert false - in - let v = - if hasAttribute "volatile" (typeAttrs typ) - then V.top_int - else V.singleton_zero - in - state := - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - !state - loc - v - with Cil.SizeOfError _ -> - Value_parameters.result ~once:true ~current:true - "cannot provide a default initializer: size is unknown" - end - in - let rec eval_init lval init = - match init with - | SingleInit exp -> - let loc = - lval_to_loc ~with_alarms:CilE.warn_none_mode - Relations_type.Model.top lval - in -( Format.printf "loc:%a state before:%a@." - Locations.pretty loc - Relations_type.Model.pretty !state; ) - let exact = cardinal_zero_or_one loc in - assert - (if not exact - then - (Cil.warning "In global initialisation, the location can not be represented. Aborting@."; - exit 1); - true); - let value = - eval_expr ~with_alarms:(warn_all_quiet_mode ()) - Relations_type.Model.top - exp - in - let v = - if hasAttribute "volatile" (typeAttrs (Cil.typeOfLval lval)) - then V.top_int - else value - in - state := - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode ~exact - !state loc v; -( Format.printf "state after:%a@." - Relations_type.Model.pretty !state; ) - - | CompoundInit (base_typ, l) -> - if not (hasAttribute "volatile" (typeAttrs base_typ)) - then - let last_bitsoffset = - foldLeftCompound - ~implicit:false - ~doinit: - (fun off init typ (acc:int) -> - let o,w = bitsOffset base_typ off in - if acc<o - then begin ( uninitialize the padding bits ) - let vi, (base_off,_) = - (match lval with - | Var vinfo, abs_offset -> - vinfo, - (bitsOffset vinfo.vtype abs_offset) - | _ -> - Value_parameters.fatal "Whacky initializer?") - in - let loc_bits = - Location_Bits.inject - (Base.create_varinfo vi) - (Ival.inject_singleton (Int.of_int (base_off+acc))) - in - let loc_size = Int_Base.inject (Int.of_int (o-acc)) in - let loc = make_loc loc_bits loc_size in -( Format.printf "loc:%a@." Locations.pretty loc; ) - state := - Relations_type.Model.add_binding_unspecified - !state - loc - end - else assert (acc=o); - if hasAttribute "volatile" (typeAttrs typ) then - Value_parameters.warning ~current:true ~once:true - "global initialization of volatile value ignored" - else - eval_init (addOffsetLval off lval) init; - o+w) - ~ct:base_typ - ~initl:l - ~acc:0 in - complete_init last_bitsoffset base_typ l lval - else () - in - Globals.Vars.iter - (fun varinfo init -> - if not varinfo.vlogic then begin - CurrentLoc.set varinfo.vdecl; - match init.init with - | None -> ( Default to zero init ) - if varinfo.vstorage = Extern - then - ( Must not assume zero when the storage is extern. *) - state := initialize_var_using_type varinfo !state - else - complete_init 0 varinfo.vtype [] (Var varinfo,NoOffset) - | Some i -> - eval_init (Var varinfo,NoOffset) i - end); - - (** Bind the declared range for NULL to uninitialized ) - if Int.le - (Base.min_valid_absolute_address ()) - (Base.max_valid_absolute_address ()) - then begin - let loc_bits = Location_Bits.inject_ival - (Ival.inject_singleton (Base.min_valid_absolute_address ())) - in - let loc_size = - Int_Base.inject - (Int.length - (Base.min_valid_absolute_address ()) - (Base.max_valid_absolute_address ())) - in - if true ( TODO: command line option ) - then - state := - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - !state - (make_loc loc_bits loc_size) - Cvalue_type.V.top_int - else - state := - Relations_type.Model.add_binding_unspecified - ( ~with_alarms:warn_none_mode - ~exact:true ) - !state - (make_loc loc_bits loc_size) - ( Cvalue_type.V.bottom ) - end; - let result = !state in - result - in - S.memo compute - - - -type predicate_value = True | False | Unknown -exception Stop -let lop_to_cop op = - match op with - | Req -> Eq - | Rneq -> Ne - | Rle -> Le - | Rge -> Ge - | Rlt -> Lt - | Rgt -> Gt - -let rec fold_on_disjunction f p acc = - match p.content with - | Por (p1,p2 ) -> fold_on_disjunction f p2 (fold_on_disjunction f p1 acc) - | _ -> f p acc - -let count_disjunction p = fold_on_disjunction (fun _pred -> succ) p 0 - -exception Predicate_alarm - -let raise_predicate_alarm () = raise Predicate_alarm - -let warn_raise_mode = - { CilE.imprecision_tracing = CilE.Aignore ; - others = CilE.Acall raise_predicate_alarm ; - unspecified = CilE.Acall raise_predicate_alarm } - -let rec reduce_by_predicate ~result ~old state positive p = - let result = - match positive,p.content with - | true,Ptrue | false,Pfalse -> state - | true,Pfalse | false,Ptrue -> Relations_type.Model.bottom - | true,Pand (p1,p2 ) | false,Por(p1,p2)-> - reduce_by_predicate ~result ~old - (reduce_by_predicate ~result ~old state positive p1) - positive - p2 - | true,Por (p1,p2 ) | false,Pand (p1, p2) -> - Relations_type.Model.join - (reduce_by_predicate ~result ~old state positive p1) - (reduce_by_predicate ~result ~old state positive p2) - - | true,Pimplies (p1,p2) -> - Relations_type.Model.join - (reduce_by_predicate ~result ~old state false p1) - (reduce_by_predicate ~result ~old state true p2) - - | false,Pimplies (p1,p2) -> - reduce_by_predicate ~result ~old - (reduce_by_predicate ~result ~old state true p1) - false - p2 - - | _,Pnot p -> reduce_by_predicate ~result ~old state (not positive) p - | true,Piff (p1, p2) -> - let red1 = - reduce_by_predicate ~result ~old - state true (Logic_const.pand (p1, p2)) - in - let red2 = - reduce_by_predicate ~result ~old state false - (Logic_const.por (p1, p2)) - in - Relations_type.Model.join red1 red2 - | false,Piff (p1, p2) -> - reduce_by_predicate ~result ~old state true - (Logic_const.por - (Logic_const.pand (p1, Logic_const.pnot p2), - Logic_const.pand (Logic_const.pnot p1, p2))) - | _,Pxor(p1,p2) -> - reduce_by_predicate ~result ~old - state (not positive) (Logic_const.piff(p1, p2)) - | _,Prel (op,t1,t2) -> - begin try - let c1 = !Db.Properties.Interp.term_to_exp ~result t1 in - let c2 = !Db.Properties.Interp.term_to_exp ~result t2 in - let t = dummy_exp (BinOp(lop_to_cop op, c1, c2, intType)) in - let state = - eval_cond ~with_alarms:warn_raise_mode - state { positive = positive ; exp = t } - in - state - with - Invalid_argument "not an lvalue" -> state - | Reduce_to_bottom -> - Relations_type.Model.bottom - ( if the exception was obtained without an alarm emitted, - it is correct to return the bottom state ) - | Predicate_alarm -> state - end - - | _,Pvalid tsets -> - begin try - let exps = !Db.Properties.Interp.loc_to_exp ~result tsets in - List.fold_left - (fun state exp -> - reduce_by_valid_expr ~with_alarms:warn_raise_mode ~positive - exp state) state exps - with Invalid_argument "not an lvalue" -> state - | Predicate_alarm -> state - end - - | _,Papp _ | _,Pold _ | _,Pat _ -> state - | _,Pexists (_varl, _p1) | _,Pforall (_varl, _p1) -> state - | _,Pfresh _ - | _,Pvalid_range (_, _, _)| _,Pvalid_index (_, _) - | _,Plet (_, _) | _,Pif (_, _, _) - | _,Psubtype _ - -> state - | _, Pseparated _ -> state - - in - result - -exception Does_not_improve - -let reduce_by_disjunction ~result ~old states n p = - if State_set.is_empty states - then states - else if (State_set.length states) (count_disjunction p) <= n - then begin - let treat_state state acc = - let treat_pred pred acc = - let result = reduce_by_predicate ~result ~old state true pred in - if Relations_type.Model.equal result state - then raise Does_not_improve - else State_set.add result acc - in - try - fold_on_disjunction treat_pred p acc - with - Does_not_improve -> State_set.add state acc - in - State_set.fold treat_state states State_set.empty - end - else - State_set.fold - (fun state acc -> - State_set.add (reduce_by_predicate ~result ~old state true p) acc) - states - State_set.empty - -let eval_predicate ~result ~old state pred = - let rec do_eval state p = - match p.content with - | Ptrue -> True - | Pfalse -> False - | Pand (p1,p2 ) -> - begin match do_eval state p1 with - | True -> do_eval state p2 - | False -> False - | Unknown -> - ( match do_eval (reduce_by_predicate ~result ~old state true p1) p2 with - False -> False - | _ -> Unknown ) - end - | Por (p1,p2 ) -> - let val_p1 = do_eval state p1 in -(* Format.printf "Conjunction: state %a p1:%a@." - Relations_type.Model.pretty state - Cil.d_predicate_named p1;) - begin match val_p1 with - | True -> -( Format.printf "Conjunction: true@."; ) - True - | False -> -( Format.printf "Conjunction: false@."; ) - do_eval state p2 - | Unknown -> begin - let reduced_state = reduce_by_predicate ~result ~old state false p1 in -( Format.printf "Conjunction: reduced to %a to eval %a@." - Relations_type.Model.pretty reduced_state - Cil.d_predicate_named p2; ) - match do_eval reduced_state p2 with - True -> True - | _ -> Unknown - end - end - | Pxor (p1,p2) -> - begin match do_eval state p1, do_eval state p2 with - | True, True -> False - | False, False -> False - | True, False | False, True -> True - | Unknown, _ | _, Unknown -> Unknown - end - | Piff (p1,p2 ) -> - begin match do_eval state p1,do_eval state p2 with - | True, True | False, False -> True - | Unknown, _ | _, Unknown -> Unknown - | _ -> False - end - | Papp _ | Pold _ | Pat _ -> Unknown - | Pvalid tsets -> begin - try - let cexps = !Db.Properties.Interp.loc_to_exp ~result tsets in - List.iter - ( fun cexp -> - let typ = typeOf cexp in - if not (isPointerType typ) - then raise Predicate_alarm; ( TODO: global arrays ) - - let evaled = - loc_bytes_to_loc_bits - (eval_expr ~with_alarms:warn_raise_mode state cexp) - in - let size = sizeof_pointed typ in - let loc = Locations.make_loc evaled size in - if not (Locations.is_valid loc) - then raise Predicate_alarm) - cexps; - True - with - Invalid_argument "not an lvalue" -> Unknown - | Predicate_alarm -> Unknown - end - | Prel (op,t1,t2) -> - begin - try - let cexp1 = !Db.Properties.Interp.term_to_exp ~result t1 in - let cexp2 = !Db.Properties.Interp.term_to_exp ~result t2 in - let cops = - dummy_exp (BinOp(lop_to_cop op, - cexp1, - cexp2, - intType)) - in - let evaled = eval_expr ~with_alarms:warn_raise_mode state cops in - if Location_Bytes.equal - evaled - Location_Bytes.singleton_zero - then - False - else if Location_Bytes.equal - evaled - Location_Bytes.singleton_one - then - True - else Unknown - with - Invalid_argument "not an lvalue" -> Unknown - | Predicate_alarm -> Unknown - end - | Pexists (varl, p1) | Pforall (varl, p1) -> - let result = - begin try - let state = List.fold_left - (fun acc var -> - match var.lv_origin with - None -> raise Exit - | Some vi -> - let loc = loc_of_varinfo vi in - Relations_type.Model.add_binding - ~with_alarms:warn_raise_mode ~exact:true - acc loc Location_Bytes.top) - state - varl - in - do_eval state p1 - with - Exit -> Unknown - | Predicate_alarm -> Unknown - end - in - begin match p.content with - | Pexists _ -> if result = False then False else Unknown - | Pforall _ -> if result = True then True else Unknown - | _ -> assert false - end - - | Pnot p -> begin match do_eval state p with - | True -> False - | False -> True - | Unknown -> Unknown - end - | Pimplies (p1,p2) -> - do_eval state (Logic_const.por ((Logic_const.pnot p1), p2)) - | Pseparated (_tset_l) -> Unknown - | Pfresh _ - | Pvalid_range (_, _, _)| Pvalid_index (_, _) - | Plet (_, _) | Pif (_, _, _) - | Psubtype _ - -> Unknown - - in - try - match State_set.fold - (fun s acc -> - match do_eval s pred with - | Unknown -> raise Stop - |( True | False ) as arg -> - (match acc with - | None -> Some arg - | Some old when old = arg -> Some arg - | _ -> raise Stop)) - state - None - with - | None -> True - | Some v -> v - with Stop -> Unknown - -let string_of_status result = - (match result with - | Unknown -> "unknown" - | True -> "valid" - | False -> "invalid") - -let check_postconditions kf kinstr ~result ~slevel header init_state state kind behaviors = - let incorporate_behavior state b = - if b.b_post_cond = [] then state - else - ( TODO: have an individual status for each post. ) - let header = - if Cil.is_default_behavior b then header - - else header ^ ", behavior " ^ b.b_name - in - let vc = Ast_info.behavior_postcondition b kind in - let assumes = - (Logic_const.pands - (List.map Logic_const.pred_of_id_pred b.b_assumes)) - in - let activated = eval_predicate ~result ~old:None init_state assumes in - let update_status st = - let ip = Property.ip_ensures_of_behavior kf kinstr b in - List.iter (swap Status.join st) ip - in - let old = init_state in - match activated with - | True -> - (let res = eval_predicate ~result ~old state vc in - Value_parameters.result ~once:true ~current:true - "%s: postcondition got status %s" header (string_of_status res); - match res with - | False -> update_status status_false; State_set.empty - | True -> - update_status status_true; - ( The reduction is needed in the True case, - because the function is "reduce_by_disjunction". - Example: //@ assert x<0 || x>=0; ) - reduce_by_disjunction ~result ~old state slevel vc - | Unknown -> - update_status status_maybe; - reduce_by_disjunction ~result ~old state slevel vc) - | Unknown -> - (let res = eval_predicate ~result ~old state vc in - Value_parameters.result ~once:true ~current:true - "%s: postcondition got status %s" header (string_of_status res); - match res with - Unknown | False -> - update_status status_maybe; - Value_parameters.result ~once:true ~current:true - "%s: postcondition got status %s, \ - but it is unknown if the behavior is active" - header (string_of_status res); - state - | True -> - update_status status_true; - Value_parameters.result ~once:true ~current:true - "%s: postcondition got status valid" header; - state) - | False -> - ( if assumes is false, post-condition status is not updated ) - Value_parameters.result ~once:true ~current:true - "%s: assumption got status invalid; post-condition not evaluated" - header; - state - in - List.fold_left incorporate_behavior state behaviors - -let check_fct_postconditions ~result kf init_state state kind = - try - let spec = (Kernel_function.get_spec kf).spec_behavior in - let slevel = get_slevel kf in - check_postconditions kf Kglobal ~result ~slevel - (Pretty_utils.sfprintf "Function %a@?" Kernel_function.pretty_name kf) - init_state state kind spec - with Not_found -> state - -let check_preconditions kf kinstr ~slevel header state spec = - let incorporate_behavior state b = - let header = - if Cil.is_default_behavior b then header - else header ^ ", behavior " ^ b.b_name - in - if b.b_requires = [] then state - else - let assumes = - (Logic_const.pands - (List.map Logic_const.pred_of_id_pred b.b_assumes)) - in - ( TODO: have an individual status for each requires. ) - let vc = - (Logic_const.pands - (List.map Logic_const.pred_of_id_pred b.b_requires)) - in - let activated = eval_predicate ~result:None ~old:None state assumes in - let update_status st = - let ip = Property.ip_requires_of_behavior kf kinstr b in - List.iter (swap Status.join st) ip - in - match activated with - | True -> - (let res = eval_predicate ~result:None ~old:None state vc in - Value_parameters.result ~once:true ~current:true - "%s: precondition got status %s" - header - (string_of_status res); - match res with - | False -> update_status status_false; State_set.empty - | True -> - update_status status_true; - ( The reduction is needed in the True case, - because the function is "reduce_by_disjunction". - Example: //@ assert x<0 || x>=0; ) - reduce_by_disjunction ~result:None ~old:None state slevel vc - | Unknown -> - update_status status_maybe; - reduce_by_disjunction ~result:None ~old:None state slevel vc) - | Unknown -> - (let res = eval_predicate ~result:None ~old:None state vc in - Value_parameters.result ~once:true ~current:true - "%s: precondition got status %s" - header - (string_of_status res); - match res with - Unknown | False -> - update_status status_maybe; - Value_parameters.result ~once:true ~current:true - "%s: precondition got status %s, but it is unknown if the behavior is active" - header (string_of_status res); - state - | True -> - update_status status_true; - Value_parameters.result ~once:true ~current:true - "%s: precondition got status valid" header; - state) - | False -> - ( if assumes is false, post-condition status is not updated ) - Value_parameters.result ~once:true ~current:true - "%s: assumption got status invalid; precondition not evaluated" - header; - state - in - List.fold_left - incorporate_behavior - state spec.spec_behavior - -let check_fct_preconditions kf state = - try - let spec = Kernel_function.get_spec kf in - let slevel = get_slevel kf in - check_preconditions kf Kglobal ~slevel - (Pretty_utils.sfprintf "Function %a@?" Kernel_function.pretty_name kf) - (State_set.singleton state) spec - with Not_found -> (State_set.singleton state) - -let extract_valid_behaviors state behavior = - List.filter - (fun b -> - let assumes = Logic_const.pands - (List.map Logic_const.pred_of_id_pred b.b_assumes) in - match eval_predicate ~result:None ~old:None state assumes with - | True | Unknown -> true - | False -> false) - behavior.spec_behavior - -( state before entering the given function ) -let valid_behaviors kf state = - extract_valid_behaviors - (State_set.singleton state) - (Kernel_function.get_spec kf) - -let () = Db.Value.valid_behaviors := valid_behaviors - - -( SEE eval_lval and do_assign to be consistent. - Same match cases must exist in order to be precise. - May raise [Lmap.Cannot_copy]. -) -let copy_offsetmap_from_virtual ~with_alarms - loc1 lv2 loc2 (state:Relations_type.Model.t) = - if (not (Int_Base.equal loc1.size loc2.size)) - || (try - ignore - (Location_Bits.cardinal_less_than loc2.loc - (Value_parameters.ArrayPrecisionLevel.get ())); - false - with Not_less_than -> true) - then begin - raise Lmap.Cannot_copy - end; - let target_offset = snd lv2 in -( let target_size = sizeof_lval lv2 in - let target_size = Int_Base.project target_size in) - let target_size = - try Int_Base.project loc2.size - with Int_Base.Error_Top -> raise Lmap.Cannot_copy - in - let result_relations = - match fst lv2 with - | Mem({enode = Lval slv} as e) when UseRelations.get () -> - let sub_left_loc = lval_to_loc ~with_alarms state slv in - begin try - let _, _, target_offset = - try - eval_offset ~reduce_valid_index:(Parameters.SafeArrays.get ()) - ~with_alarms None (typeOf e) state target_offset - with Offset_not_based_on_Null _ -> raise Lmap.Cannot_copy - in - let offsetmap = - Relations_type.Model.copy_from_virtual - sub_left_loc target_offset target_size state - in - offsetmap - with Relations_type.Use_Main_Memory -> - Cvalue_type.V_Offsetmap.empty - end - | Mem({enode = BinOp((PlusPI|IndexPI|MinusPI as op), - {enode = Lval slv},e2,_)} as e) - when UseRelations.get () -> - let typ = typeOf e in - let e2 = eval_expr ~with_alarms state e2 in - begin try - - let ival = (Cvalue_type.V.project_ival e2) in - let ival = if op=MinusPI then Ival.neg ival else ival in - let ival = Ival.scale - (Int_Base.project (sizeof_pointed typ)) - ival - in - let sub_left_loc = lval_to_loc ~with_alarms state slv in - (TODO: with_alarms:false should be used ? ) - let _, _, target_offset = eval_offset - ~reduce_valid_index:(Parameters.SafeArrays.get ()) - ~with_alarms None typ state target_offset in - let target_offset = Ival.add target_offset ival in - let offsetmap = - Relations_type.Model.copy_from_virtual - sub_left_loc target_offset target_size state - in - offsetmap - with Relations_type.Use_Main_Memory | Cvalue_type.V.Not_based_on_null -> - Cvalue_type.V_Offsetmap.empty - end - - | _ -> - Cvalue_type.V_Offsetmap.empty - in - result_relations - -let need_cast t1 t2 = - match (unrollType t1, unrollType t2) with - | (TInt _| TEnum _| TPtr _),(TInt _| TEnum _| TPtr _) - | (TFloat _,TFloat _) - | (TComp _, TComp _) -> - (try bitsSizeOf t1 <> bitsSizeOf t2 - with SizeOfError _ -> true) - | _ -> true - - -module Computer - (AnalysisParam:sig - val stmt_can_reach : stmt -> stmt -> bool - val is_natural_loop : stmt -> bool - val slevel: int - val initial_state : State_set.t - end) = - -struct - let debug = ref false - let name = "Values analysis" - - let stmt_can_reach = AnalysisParam.stmt_can_reach - let slevel = AnalysisParam.slevel - let debug = ref false - - let current_table = Current_table.create () - - let states_after = Cil_datatype.Stmt.Hashtbl.create 17 - - - ( During the dataflow analysis, if required by a callback, we store the - state after a statement, but only if the following conditions are met - ([succ] being a successor of [s]) - - if [s] is an instr (which almost always change the state, unlike - the other kind of statements) - - if there is a control-flow join on [succ] - - if [s] is the last instruction of a block that contains - local variables - For statements for which the function below returns false, we deduce - the state after by the state before [succ] or another successor of [s]. - This avoid potentially useless computations - ) - let store_state_after_during_dataflow s succ = - ((match s.skind with Instr _ -> true | _ -> false) && - (match succ.preds with [_] -> false | _ -> true)) - || (let b1 = Kernel_function.find_enclosing_block s - and b2 = Kernel_function.find_enclosing_block succ in - not (Cil_datatype.Block.equal b1 b2) && b1.blocals <> []) - - - let merge_current ~degenerate = - let superposed = lazy (Current_table.states current_table) in - Current_table.merge_db_table superposed; - if not degenerate && - ((not (Db.Value.Record_Value_Callbacks.is_empty ())) || - (not (Db.Value.Record_Value_Superposition_Callbacks.is_empty ())) || - (not (Db.Value.Record_Value_After_Callbacks.is_empty ()))) - then begin - let stack_for_callbacks = for_callbacks_stack () in - - if not (Db.Value.Record_Value_Superposition_Callbacks.is_empty ()) - then begin - let current_superpositions = - Current_table.superpositions current_table - in - Value_parameters.feedback - "now calling Record_Value_Superposition callbacks"; - Db.Value.Record_Value_Superposition_Callbacks.apply - (stack_for_callbacks, current_superpositions); - end ; - - if not (Db.Value.Record_Value_Callbacks.is_empty ()) - then begin - Value_parameters.feedback "now calling Record_Value callbacks"; - Db.Value.Record_Value_Callbacks.apply - (stack_for_callbacks, Lazy.force superposed) - end; - - if not (Db.Value.Record_Value_After_Callbacks.is_empty ()) - then begin - Value_parameters.feedback "now calling Record_After_Value callbacks"; - let superposed = Lazy.force superposed in - Cil_datatype.Kinstr.Hashtbl.iter - (fun ki state -> - match ki with - | Kglobal -> () - | Kstmt stmt -> - List.iter - (fun pred -> - if not (store_state_after_during_dataflow pred stmt) - then - try - let cur = Cil_datatype.Stmt.Hashtbl.find - states_after pred in - Cil_datatype.Stmt.Hashtbl.replace - states_after pred - (Relations_type.Model.join state cur) - with Not_found -> - Cil_datatype.Stmt.Hashtbl.add - states_after pred state - ) - stmt.preds; - ) - superposed; - ( Since the return instruction has no successor, it is not visited - by the iter above. We fill it manually ) - let ret = Kernel_function.find_return (current_kf ()) in - (try - let s = Cil_datatype.Kinstr.Hashtbl.find superposed (Kstmt ret) in - Cil_datatype.Stmt.Hashtbl.add states_after ret s - with Not_found -> () - ); - - - Db.Value.Record_Value_After_Callbacks.apply - (stack_for_callbacks, states_after); - end; - - end; - Current_table.clear current_table - - type u = - { counter_unroll : int; ( how many times this state has been crossed *) - mutable value : State_set.t ; } - - module StmtStartData = - Dataflow.StmtStartData(struct type t = u let size = 107 end) - - type t = u - - let copy (d: t) = d - - let display_one fmt v = - State_set.iter (fun value -> - if not (Relations_type.Model.is_reachable value) then begin - Format.fprintf fmt "Statement (x%d): UNREACHABLE@\n" - v.counter_unroll ; - end - else - (Format.fprintf fmt "Statement (x%d)@\n%a" - v.counter_unroll - Relations_type.Model.pretty - value)) - (v.value) - - let pretty fmt (d: t) = display_one fmt d - - let computeFirstPredecessor (_s: stmt) state = - { - counter_unroll = 0; - value = state.value;} - - let getWidenHints (s: stmt) = - Widen.getWidenHints (current_kf()) s - - let counter_unroll_target = ref 100 - - let combinePredecessors (_s: stmt) ~old new_ = - if State_set.is_empty (new_.value) - then None - else begin - if old.counter_unroll >= slevel - then - let sum = - Relations_type.Model.join - (State_set.join (new_.value)) - (State_set.join (old.value)) - in - Some {counter_unroll = old.counter_unroll ; - value = (State_set.singleton sum);} - else begin try - let merged = State_set.merge_into (new_.value) (old.value) in - let length_new = State_set.length (new_.value) in - let new_counter_unroll = old.counter_unroll + length_new in - if new_counter_unroll >= !counter_unroll_target - then begin - Value_parameters.result ~once:true - "Semantic level unrolling superposing up to %d states" - !counter_unroll_target; - counter_unroll_target := !counter_unroll_target + 100; - end; - let result = - Some - { value = merged ; - counter_unroll = new_counter_unroll } - in - result - with State_set.Unchanged -> None - end - end - - - - -(** Precondition: the type of [exp] and the type [loc_lv] may be different - only if the cast from [typeOf exp] and [typeOf loc_lv] is a truncation - or an extension. - This function will not perform any conversion (float->int, int->float, ...) - [exp] should not be bottom for optimization purposes in the caller. - ) - let do_assign_abstract_value_to_loc ~with_alarms state lv loc_lv exp = - assert (not (Cvalue_type.V.is_bottom exp)); - ( Or one may propagate bottoms uselessly for too long. ) - let exp = ( truncate the value if the [lv] is too small: this may - happen when the [lv] is a bitfield. Otherwise, the - cast is explicit thanks to Cil and no truncation is - necessary. ) - try - ( if it is a bitfield, the size is statically known. ) - let size = Int_Base.project loc_lv.size in - try - let old_ival = V.project_ival exp in - let exp = - V.inject_ival ( Inject on null as [project_ival] did not raise - [Not_based_on_null] ) - (Ival.cast - ~size - ~signed:(signof_typeof_lval lv) - ( the sign can be computed on integral types. ) - ~value:old_ival) - in - exp - with - | V.Not_based_on_null ( from [project_ival] ) -> - ( The exp is a pointer: check there are enough bits in - the bitfield to contain it. ) - if Int.compare size (Int.of_int (sizeofpointer ())) >= 0 - || V.is_imprecise exp - then exp - else begin - Value_parameters.result "casting address to a bitfield of %s bits: this is smaller than sizeof(void)" (Int.to_string size); - V.topify_arith_origin exp - end - | Neither_Int_Nor_Enum_Nor_Pointer - (* from [signof_typeof_lval] ) -> exp - with - | Int_Base.Error_Top | Int_Base.Error_Bottom -> - ( from [project]: size is not known ) - exp - in - let pretty_org fmt org = if not (Origin.is_top org) then - Format.fprintf fmt " because of %a" Origin.pretty org - in - (match loc_lv.loc with - | Location_Bits.Top (Location_Bits.Top_Param.Top, orig) -> - Value_parameters.result - "State before degeneration:@\n======%a@\n=======" - Relations_type.Model.pretty state; - Value_parameters.warning ~once:true - "writing at a completely unknown address@[%a@].@\nAborting." - pretty_org orig; - do_degenerate (Some lv) - - | Location_Bits.Top((Location_Bits.Top_Param.Set _) as param,orig) -> - Value_parameters.result ~current:true ~once:true - "writing somewhere in @[%a@]@[%a@]." - Location_Bits.Top_Param.pretty param - pretty_org orig - | Location_Bits.Map _ -> ( everything is normal *) ()); - let exact = valid_cardinal_zero_or_one loc_lv in - let value = - Relations_type.Model.add_binding ~with_alarms ~exact - state loc_lv exp - in - value - - (** Clobber list for bases containing addresses of local variables. *) - let bases_containing_locals = ref Location_Bits.Top_Param.bottom - let remember_bases_with_locals = - remember_bases_with_locals bases_containing_locals - - (** Precondition: the type of [exp] and the type [loc_lv] may be different - only if the cast from [typeOf exp] - and [typeOfPointed lv] is a truncation or an extension. - This function will not perform any conversion (float->int, int->float,..) - ) - let do_assign_abstract_value ~with_alarms - ~former_state - (state:Relations_type.Model.t) - lv - exp = - let state_for_lv = - if true (!Cabs2cil.forceRLArgEval) then state - else former_state - in - let loc_lv = lval_to_loc ~with_alarms state_for_lv lv in - remember_bases_with_locals loc_lv exp; - CilE.set_syntactic_context (CilE.SyMem lv); - do_assign_abstract_value_to_loc ~with_alarms state lv loc_lv exp - - - let offsetmap_top_addresses_of_locals is_local = - let is_local_bytes = Location_Bytes.contains_addresses_of_locals is_local in - fun offsetmap -> - if Cvalue_type.V_Offsetmap.is_empty offsetmap - then offsetmap, true - else - let found_locals = ref false in - let loc_contains_addresses_of_locals t = - let l = - is_local_bytes (Cvalue_type.V_Or_Uninitialized.get_v t) - in - found_locals := !found_locals - || (l - && (match Cvalue_type.V_Or_Uninitialized.get_v t with - | Location_Bytes.Top (Location_Bytes.Top_Param.Top,_) -> false - ( Do not be too verbose if the value is top. ) - | _ -> true)); - l - in - let result = - Cvalue_type.V_Offsetmap.top_stuff - loc_contains_addresses_of_locals - (fun v -> - Cvalue_type.V_Or_Uninitialized.unspecify_escaping_locals - is_local v) - offsetmap - in - result, !found_locals - - let state_top_addresses_of_locals ~is_block - offsetmap_top_addresses_of_locals fundec - = - let f k offsm = - let r,found_locals = offsetmap_top_addresses_of_locals offsm in - if found_locals then - warn_locals_escape is_block fundec k; - r - in - (fun (state:Relations_type.Model.t) -> - ( let's forget relations ) - let simple_state = Relations_type.Model.value_state state in - let f base acc = - try - let offset_to_clean = Cvalue_type.Model.find_base base simple_state - in - let cleaned_offsetmap = f base offset_to_clean in - Cvalue_type.Model.add_offsetmap base cleaned_offsetmap acc - with Not_found -> acc - in - try - Relations_type.Model.inject - (Location_Bits.Top_Param.fold - f - !bases_containing_locals - (f Base.null simple_state)) - with Location_Bits.Top_Param.Error_Top -> - begin - let f k offsm acc = - let r,found_locals = offsetmap_top_addresses_of_locals offsm in - if found_locals then - warn_locals_escape is_block fundec k; - Cvalue_type.Model.add_offsetmap k r acc - in - let result = - try - Relations_type.Model.inject - (Cvalue_type.Model.fold_base_offsetmap - f - (Relations_type.Model.value_state state) - Cvalue_type.Model.empty_map) - with Cvalue_type.Model.Error_Bottom -> Relations_type.Model.bottom - in - result - - end) - - let top_addresses_of_locals fundec = - let entry_point = Globals.entry_point () in - if snd entry_point ( lib ) || - current_kf() != fst entry_point ( not entry point ) - then - let offsetmap_top_addresses_of_locals = - offsetmap_top_addresses_of_locals (swap Base.is_formal_or_local fundec) - in - let state_top_addresses_of_locals = - state_top_addresses_of_locals ~is_block:false - offsetmap_top_addresses_of_locals fundec - in - offsetmap_top_addresses_of_locals, state_top_addresses_of_locals - else (fun x -> x,false),(fun x -> x) - - let block_top_addresses_of_locals blocks = - if List.for_all (fun b -> List.for_all (fun v -> v.vgenerated) b.blocals) - blocks - then - fun x -> x ( no need to change the state if there is no local - variable or if all the variable have been generated - by Cil (in which case we know that they are correctly - initialized and used, don't we) - ) - else - let offsetmap_top_addresses_of_locals = - offsetmap_top_addresses_of_locals - (fun v -> List.exists (Base.is_block_local v) blocks) - in - let state_top_addresses_of_locals = - state_top_addresses_of_locals ~is_block:true - offsetmap_top_addresses_of_locals - (Kernel_function.get_definition (current_kf())) - in - state_top_addresses_of_locals - - ( Assigns [exp] to [lv] in [state] ) - let do_assign ~with_alarms old_state lv exp = - assert (Relations_type.Model.is_reachable old_state); - let fresh_flags () = - let flag = ref false in - (fun () -> flag := true), - fun () -> !flag - in - let set_alarm, get_alarm = fresh_flags () in - let logger v = - if v <> CilE.Aignore - then CilE.Acall set_alarm - else CilE.Aignore - in - let warn_remember_mode = - { CilE.imprecision_tracing = logger with_alarms.CilE.imprecision_tracing; - others = with_alarms.CilE.others; - unspecified = logger with_alarms.CilE.unspecified} - in - let reduced_state, _, evaled_exp = - eval_expr_with_deps_state_subdiv ~with_alarms:warn_remember_mode None - old_state - exp - in - Value_parameters.debug ~level:2 "do_assign %a = (%a)(%a)" - !d_lval lv - !d_exp exp - V.pretty evaled_exp; - let left_loc = lval_to_loc ~with_alarms old_state lv in - remember_bases_with_locals left_loc evaled_exp; - let warn_right_exp_imprecision () = - (match with_alarms.CilE.imprecision_tracing with - | CilE.Aignore -> () - | CilE.Acall f -> f () - | CilE.Alog -> - match evaled_exp with - | Cvalue_type.V.Top(_topparam,origin) -> - Value_parameters.result ~once:true ~current:true - "assigning imprecise value to @[%a@]@[%t@]@[%a@]" - !Ast_printer.d_lval lv - (fun fmt -> match lv with - | (Mem _, _) -> - Format.fprintf fmt " (i.e. %a)" Locations.pretty left_loc - | (Var _, _) -> ()) - (fun fmt org -> - if not (Origin.is_top origin) then - Format.fprintf fmt ".@ The imprecision originates from %a" - Origin.pretty org) - origin - | Cvalue_type.V.Map _ -> - if not (Got_Imprecise_Value.get ()) && - not (Cvalue_type.V.cardinal_zero_or_one evaled_exp) - then begin - Got_Imprecise_Value.set true; - Value_parameters.result ~current:true - "assigning non deterministic value for the first time"; - end) - in - let reduced_state = - match lv with - Mem mem_e,NoOffset -> - let new_reduced_state = - reduce_by_valid_expr ~with_alarms ~positive:true mem_e reduced_state - in - if not (Relations_type.Model.is_reachable new_reduced_state) - then begin - CilE.set_syntactic_context (CilE.SyMem lv); - CilE.warn_mem_write with_alarms ; - Value_parameters.result ~current:true - "all target addresses were invalid. This path is assumed to be dead."; - end; - new_reduced_state - ( | Var _ , Index _ -> assert false - TODO: do something for "TAB[i] = expr" - ) - | _ -> reduced_state - in - let default () = - warn_right_exp_imprecision (); - if get_alarm() then - ( log alarms that have not been logged the first time ) - ignore - (eval_expr - ~with_alarms: - {CilE.imprecision_tracing=with_alarms.CilE.imprecision_tracing; - others=CilE.Aignore; - unspecified=with_alarms.CilE.unspecified} - old_state - exp); - - if Cvalue_type.V.is_bottom evaled_exp || - Location_Bits.equal left_loc.loc Location_Bits.bottom || - not (Relations_type.Model.is_reachable reduced_state) - then Relations_type.Model.bottom - else begin - CilE.set_syntactic_context (CilE.SyMem lv); - do_assign_abstract_value_to_loc ~with_alarms - reduced_state - lv - left_loc - evaled_exp - end - in - let default_lval exp_lv = - ( directly copy the old value without trying to recompose it. - Useful for structs assignment. ) - let right_loc = lval_to_loc ~with_alarms old_state exp_lv in - - CilE.set_syntactic_context (CilE.SyMem exp_lv); - let full_val = - Relations_type.Model.find_unspecified - ~with_alarms:CilE.warn_none_mode - old_state - right_loc - in - if Location_Bits.equal left_loc.loc Location_Bits.bottom || - not (Relations_type.Model.is_reachable reduced_state) || - V_Or_Uninitialized.equal full_val V_Or_Uninitialized.bottom - then Relations_type.Model.bottom - else begin - match right_loc.size, left_loc.size with - | Int_Base.Value size, Int_Base.Value other_size - when Int.equal other_size size -> - let offsetmap_relations = - try - copy_offsetmap_from_virtual - ~with_alarms - right_loc exp_lv left_loc old_state - with Lmap.Cannot_copy -> - Cvalue_type.V_Offsetmap.empty - in - CilE.set_syntactic_context (CilE.SyMem exp_lv); - let offsetmap_memory = - match Relations_type.Model.copy_offsetmap ~with_alarms right_loc old_state with - | Some v -> v - | None -> raise Lmap.Cannot_copy ( invalid copy paste ) - in - let offsetmap = - Cvalue_type.V_Offsetmap.over_intersection - offsetmap_relations - offsetmap_memory - in - if not (Cvalue_type.V_Offsetmap.is_empty offsetmap) - then begin - CilE.set_syntactic_context (CilE.SyMem lv); - let copy_paste_succeeded = - Relations_type.Model.paste_offsetmap - offsetmap left_loc.loc Int.zero size reduced_state - in - ( Shall we warn about imprecise contents just copied? ) - let module L = struct exception Got_imprecise end in - (try - Cvalue_type.V_Offsetmap.iter_contents - (fun v -> - match Cvalue_type.V_Or_Uninitialized.get_v v with - | Location_Bytes.Map _ -> () - | _ -> raise L.Got_imprecise) - offsetmap - size - with L.Got_imprecise -> - warn_right_exp_imprecision ()); - copy_paste_succeeded - end - else raise Lmap.Cannot_copy - | _ -> raise Lmap.Cannot_copy - end - in - let new_main_memory_state = - try - ( An lval assignement might be hidden by a dummy cast ) - let lv = find_lv ~with_alarms old_state exp in - default_lval lv - with | Cannot_find_lv | Lmap.Cannot_copy - ( from Relations_type.Model.paste_offsetmap or directly default_lval ) -> - default () - in ( The main memory state is now computed. ) - ( Let's try to improve it with relations ) - if UseRelations.get () - && Relations_type.Model.is_reachable new_main_memory_state - then begin - if ( hasAttribute "volatile" (typeAttrs (typeOf exp)) - || hasAttribute "volatile" (typeAttrs (Cil.typeOfLval lv)) doesn't work ) - false - then begin - Relations_type.Model.propagate_change_from_real_to_virt - [] - left_loc - new_main_memory_state - evaled_exp - end - else - let list_lv = find_lv_plus ~with_alarms old_state exp in - try - let (_lv_right,offs_right) = - List.find - (fun (lv_right,_offs_right) -> - Location_Bits.equal left_loc.loc - (lval_to_loc ~with_alarms:CilE.warn_none_mode old_state lv_right).loc) - list_lv ( Check for a self assignement ) - in - Relations_type.Model.shift_location - new_main_memory_state - left_loc - offs_right - evaled_exp - with Not_found -> ( not a self assignement ) - let protected_clusters,optimized_state_value = - match lv with - | Mem({enode = Lval slv} as e),offs -> - let sub_left_loc = - lval_to_loc ~with_alarms old_state slv - in - if Location_Bits.is_relationable sub_left_loc.loc then - Relations_type.Model.add_mem - sub_left_loc - (sizeof_lval lv) - (try - let _,_,offset = - eval_offset - ~reduce_valid_index:(Parameters.SafeArrays.get ()) - ~with_alarms - None (typeOf e) old_state offs - in - offset - with Offset_not_based_on_Null _ -> Ival.top) - new_main_memory_state - evaled_exp - else [],new_main_memory_state - - | Mem({enode = BinOp((PlusPI|IndexPI|MinusPI as op), - { enode = Lval slv},e2,_)} as e), - offs -> - let typ = typeOf e in - let e2 = eval_expr ~with_alarms old_state e2 in - begin try - let ival = Cvalue_type.V.project_ival e2 in - let ival = if op = MinusPI then Ival.neg ival else ival - in - let _, _, offs = - eval_offset - ~reduce_valid_index:(Parameters.SafeArrays.get ()) - ~with_alarms - None typ old_state offs - in - let offs = ( convert to bits ) - Ival.add - (Ival.scale - (Int_Base.project (sizeof_pointed typ)) - ival) - offs - in - let sub_left_loc = - lval_to_loc ~with_alarms old_state slv - in - if Location_Bits.is_relationable sub_left_loc.loc - then - Relations_type.Model.add_mem - sub_left_loc - (sizeof_lval lv) - offs - new_main_memory_state - evaled_exp - else [],new_main_memory_state - with - | Offset_not_based_on_Null _ - | Int_Base.Error_Top - | Cvalue_type.V.Not_based_on_null -> [],new_main_memory_state - end - | _ -> [],new_main_memory_state - in - ( Let's clean the obsoleted relations. ) - let optimized_state_value = - Relations_type.Model.propagate_change_from_real_to_virt - protected_clusters - left_loc - optimized_state_value - evaled_exp - in - let rec optimize_list_lv l = - match l with - [] -> optimized_state_value - | (lvr,offset) :: tail -> - if Ival.is_singleton_int offset - then begin - let locr = lval_to_loc ~with_alarms old_state lvr in - if Location_Bits.is_relationable locr.loc - then - Relations_type.Model.add_equality - ?offset:(Some (Ival.neg offset)) - optimized_state_value left_loc locr - else optimize_list_lv tail - end - else optimize_list_lv tail - in - optimize_list_lv list_lv - end - else new_main_memory_state - - - - let do_assign ~with_alarms old_state lv exp = - if true then do_assign ~with_alarms old_state lv exp - else - let vars = - get_influential_vars ~with_alarms:CilE.warn_none_mode old_state exp - in - let rec try_sub vars = - match vars with - [] | [ _ ] -> - do_assign ~with_alarms old_state lv exp - | v :: tail -> - try - if not (List.exists (fun x -> Locations.loc_equal v x) tail) - then raise Too_linear; - let value = - Relations_type.Model.find - ~conflate_bottom:true - ~with_alarms:CilE.warn_none_mode - old_state - v - in - - if Locations.Location_Bytes.is_included value Locations.Location_Bytes.top_float - then raise Too_linear; - - ignore (Cvalue_type.V.splitting_cardinal_less_than - ~split_non_enumerable:42 value 142); - Value_parameters.debug - "subdiv assignment: candidate %a value %a@." - Locations.pretty v - Cvalue_type.V.pretty value; - let treat_subdiv subvalue acc = - let sub_oldstate = - ( FIXME: should be relation-aware primitive ) - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:true - old_state - v - subvalue - in - let sub_newstate = - do_assign ~with_alarms sub_oldstate lv exp - in - Relations_type.Model.join acc sub_newstate - in - Location_Bytes.fold_enum - ~split_non_enumerable:42 - treat_subdiv - value - Relations_type.Model.bottom - with - Not_less_than | Too_linear -> - try_sub tail - | Location_Bytes.Error_Top -> - assert false; - in - try_sub vars - - exception Got_bottom - - let empty_interpretation_result = - None, Relations_type.Model.bottom, Location_Bits.Top_Param.bottom - - let offsetmap_of_lv ~with_alarms state lv = - CilE.set_syntactic_context (CilE.SyMem lv); - let loc_to_read = - lval_to_loc ~with_alarms state lv - in - Relations_type.Model.copy_offsetmap - ~with_alarms:CilE.warn_none_mode - loc_to_read - state - - let interp_call stmt lval_to_assign funcexp argl d_value = - let call_site_loc = CurrentLoc.get () in - let with_alarms = warn_all_quiet_mode () in - let treat_one_state state acc = - let new_state_after_call = - try - let _, functions = - resolv_func_vinfo ~with_alarms - None state funcexp - in - let is_library_function kf = - not (Kernel_function.is_definition kf) - in - let calling_at_least_one_library_function = - Kernel_function.Hptset.exists - is_library_function - functions - in - let calling_all_library_functions = - calling_at_least_one_library_function && - (Kernel_function.Hptset.for_all - is_library_function - functions) - in - let actuals = - List.map - (fun e -> - let interpreted_expr, o = - match e with - { enode = Lval l } -> - let _, _, interpreted_expr = - eval_lval ~conflate_bottom:false ~with_alarms - None state l - in - if calling_at_least_one_library_function - then begin - let _, _, conf_expr = - eval_lval ~conflate_bottom:true ~with_alarms - None state l - in - ignore (conf_expr); - end; - if calling_all_library_functions && - V.is_bottom interpreted_expr - then begin - Value_parameters.result ~current:true - "Non-termination in evaluation of library function call l-value argument"; - raise Got_bottom; - end; - let r = do_cast ~with_alarms (typeOf e) interpreted_expr - in - let o = - offsetmap_of_lv ~with_alarms:(warn_all_quiet_mode ()) - state - l - in - r, out_some o - | _ -> - let interpreted_expr = - eval_expr ~with_alarms state e - in - if V.equal interpreted_expr V.bottom - then begin - Value_parameters.result ~current:true - "Non-termination in evaluation of function call expression argument"; - raise Got_bottom - end; - interpreted_expr, - Builtins.offsetmap_of_value ~typ:(Cil.typeOf e) - interpreted_expr - in - e,interpreted_expr,o) - argl - in - let treat_one_call f (acc_rt,acc_res,acc_clobbered_set) = - let caller = current_kf (), stmt in - Kf_state.add_caller f ~caller; - let return, result, clobbered_set = - !compute_call_ref - f - ~call_kinstr:(Kstmt stmt) - state - actuals - in - CurrentLoc.set call_site_loc; - (match acc_rt,return with - | None,_ -> return - | Some _, None -> acc_rt - | Some acc_rt, Some return -> - Some (snd (V_Offsetmap.join - acc_rt - return))), - Relations_type.Model.join acc_res result, - Location_Bits.Top_Param.join acc_clobbered_set clobbered_set - in - let return,new_state,clobbered_set = - Kernel_function.Hptset.fold - treat_one_call - functions - empty_interpretation_result - in - - bases_containing_locals := - Location_Bits.Top_Param.join - !bases_containing_locals - clobbered_set; - - match lval_to_assign with - | None -> new_state - | Some lv -> - begin match return with - | Some return -> - let loc = - lval_to_loc - ~with_alarms new_state lv - in - let rtype = - getReturnType (typeOf funcexp) - in - let lvtyp = typeOfLval lv in - let default () = - let value_with_init - = - V_Offsetmap.find_ival - ~conflate_bottom:false - ~validity:Base.All - ~with_alarms:CilE.warn_none_mode - Ival.zero - return - (Int.of_int (bitsSizeOf rtype)) - in - let flags = V_Or_Uninitialized.get_flags value_with_init - in - let init = V_Or_Uninitialized.is_initialized flags in - let no_esc = V_Or_Uninitialized.is_noesc flags in - let value = V_Or_Uninitialized.get_v value_with_init in - if not init - then CilE.warn_uninitialized with_alarms; - if not no_esc - then CilE.warn_escapingaddr with_alarms; - if Cvalue_type.V.is_bottom value - && not (init && no_esc) - then - Value_parameters.result ~current:true - "Function call returned an unspecified value. This path is assumed to be dead."; - - let exact = valid_cardinal_zero_or_one loc in - let evaled_exp = - do_cast - ~with_alarms:CilE.warn_none_mode - lvtyp - value - in - remember_bases_with_locals loc evaled_exp; - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact - new_state - loc - evaled_exp - in - if need_cast lvtyp rtype - then - default () - else - (try - let result = - Relations_type.Model.paste_offsetmap - return - loc.loc - Int.zero - (Int_Base.project loc.size) - new_state - in - let evaled_exp= - Cvalue_type.V_Or_Uninitialized.get_v - (V_Offsetmap.find_ival - ~conflate_bottom:false - ~validity:Base.All - ~with_alarms:CilE.warn_none_mode - Ival.zero - return - (Int.of_int (bitsSizeOf rtype)) - ) - in - remember_bases_with_locals loc evaled_exp; - result - with Lmap.Cannot_copy -> default ()) - | None -> - (if Relations_type.Model.is_reachable new_state - then - Value_parameters.warning ~current:true - "In function %t: called function returns void but returned value is assigned; ignoring assignment" - pretty_current_cfunction_name; - new_state) - end - with - | Ignore -> - CurrentLoc.set call_site_loc; - state - | Got_bottom -> - CurrentLoc.set call_site_loc; - Relations_type.Model.bottom - | Leaf -> - CurrentLoc.set call_site_loc; - (match lval_to_assign with - | None -> state - | Some lv -> - let evaled_exp = V.top_leaf_origin () in - do_assign_abstract_value - ~with_alarms - ~former_state:state - state - lv - evaled_exp) - in - State_set.add new_state_after_call acc - in - State_set.fold - treat_one_state - d_value - State_set.empty - - let doInstr stmt (i: instr) (d: t) = - !Db.progress (); - CilE.start_stmt (Kstmt stmt); - let d_states = (d.value) in - let unreachable = State_set.is_empty d_states in - let result = - if unreachable then - Dataflow.Done d - else begin - let apply_each_state f = - let modified_states = - State_set.fold - (fun state_value acc -> State_set.add (f state_value) acc) - d_states - State_set.empty - in - Dataflow.Done { counter_unroll = 0; value = modified_states } - in - ( update current statement ) - match i with - | Set (lv,exp,_loc) -> - apply_each_state - (fun state_value -> - do_assign - ~with_alarms:(warn_all_quiet_mode ()) - state_value - lv - exp) - | Call (None, - {enode = Lval (Var {vname=("__builtin_va_start"|"__builtin_va_arg"|"__builtin_va_end" as _builtin_name) },NoOffset)}, - [{enode = Lval lv}],_loc) -> -( Format.printf "builtin: %s@." _builtin_name; ) - apply_each_state - (fun state_value -> - do_assign_abstract_value - ~with_alarms:(warn_all_quiet_mode ()) - ~former_state:state_value - state_value - lv - Cvalue_type.V.top_int) - | Call (lval_to_assign,funcexp,argl,_loc) -> - Dataflow.Done - { - counter_unroll = 0; - value = - (interp_call stmt lval_to_assign funcexp argl d_states) - } - | Asm _ -> - Value_parameters.warning ~once:true ~current:true - "assuming assembly code has no effects in function %t" - pretty_current_cfunction_name; - Dataflow.Default - | Skip _ -> - Dataflow.Default - | Code_annot (_,_) -> ( processed in dostmt from Db ) - Dataflow.Default - end - in - CilE.end_stmt (); - result - - let interp_annot state stmt ca = - match ca.annot_content with - | AAssert (behav,p) -> - let in_behavior = - match behav with - [] -> True - | [ behav ] -> - let initial_state_single = - State_set.join AnalysisParam.initial_state in - let _valid_behaviors = - valid_behaviors - (current_kf()) - initial_state_single - in - if List.exists (fun b -> b.b_name = behav) _valid_behaviors - then Unknown - else False - | _ -> Unknown - in - if in_behavior = False - then state - else - let result = eval_predicate ~result:None ~old:None state p in - let ip = Property.ip_of_code_annot (current_kf()) stmt ca in - let change_status st = List.iter (swap Status.join st) ip in - let message, result = - (match result, in_behavior with - | Unknown, _ | False, Unknown -> - change_status status_maybe; - "unknown", state - | True, _ -> - change_status status_true; - "valid", state - | False, True -> - change_status status_false; - "invalid (stopping propagation).", State_set.empty - | _, False -> assert false) - in - let result = - if in_behavior = True - then - reduce_by_disjunction ~result:None ~old:None - result - AnalysisParam.slevel - p - else result - in - Value_parameters.result ~once:true ~current:true - "Assertion got status %s." message; - result - | APragma _ - | AInvariant _ (TODO) - | AVariant _ | AAssigns _ - | AStmtSpec _ (TODO) -> state - - let check_non_overlapping state lvs1 lvs2 = - List.iter - (fun lv1 -> - List.iter - (fun lv2 -> - let zone1 = - Locations.valid_enumerate_bits - (lval_to_loc ~with_alarms:CilE.warn_none_mode state lv1) - in - let zone2 = - Locations.valid_enumerate_bits - (lval_to_loc ~with_alarms:CilE.warn_none_mode state lv2) - in - if Locations.Zone.intersects zone1 zone2 - then begin - CilE.set_syntactic_context - (CilE.SySep - (Cil.mkAddrOf ~loc:(CurrentLoc.get ()) lv1, - Cil.mkAddrOf ~loc:(CurrentLoc.get ()) lv2)); - CilE.warn_separated CilE.warn_all_mode - end) - lvs2) - lvs1 - -( TODO: Take advantage of calls information. ) - let check_unspecified_sequence state seq = - let rec check_one_stmt ((stmt1,_,writes1,_,_) as my_stmt) = function - [] -> () - | (stmt2,_,_,_,_)::seq when stmt1 == stmt2 -> check_one_stmt my_stmt seq - | (stmt2,modified2,writes2,reads2,_) :: seq -> - let unauthorized_reads = - ( TODO: try to have a more semantical interpretation of modified ) - List.filter - (fun x -> List.for_all (fun y -> not (Lval.equal x y)) modified2) - writes1 - in - check_non_overlapping state unauthorized_reads reads2; - if stmt1.sid < stmt2.sid then - check_non_overlapping state writes1 writes2; - check_one_stmt my_stmt seq - in - if Parameters.UnspecifiedAccess.get () then - List.iter (fun x -> check_one_stmt x seq) seq - - let doStmt (s: stmt) (d: t) = - let states = (d.value) in - d.value <- State_set.empty; - let kinstr = Kstmt s in - - - let not_already_states = - Current_table.update_and_tell_if_changed - current_table - kinstr - states - in - - if State_set.is_empty not_already_states then - Dataflow.SDefault - else begin - - let annots_before, contract = - Annotations.single_fold_stmt - (fun a (before, spec as acc) -> match a with - | Before - (User { annot_content = AStmtSpec spec' } - | AI (_,{annot_content = AStmtSpec spec' }) ) - -> - let spec = match spec with - | None -> spec' - | Some s -> Logic_utils.merge_funspec s spec'; s - in - (before, Some spec) - | Before (AI (_, b) | User b) -> b :: before, spec - | After _ -> acc) - s - ([], None) - in - - CilE.start_stmt kinstr; - let states = - List.fold_left - (fun states annot -> interp_annot states s annot) - states - annots_before - in - let states = - match contract with - Some spec -> - check_preconditions (current_kf()) kinstr - ~slevel "statement" states spec - | None -> states - in - CilE.end_stmt (); - - let curr_wcounter, curr_wstate = - Current_table.find_widening_info current_table kinstr in - let d = - if d.counter_unroll >= AnalysisParam.slevel - then begin - let state = State_set.join states in - let joined = - Relations_type.Model.join - curr_wstate - state - in - let r = - if (AnalysisParam.is_natural_loop s) && - (curr_wcounter = 0) - then - let wh_key_set, wh_hints = getWidenHints s in - let widen_hints = - true, wh_key_set( no longer used thanks to 0/1 widening), - wh_hints - in - let _,result = Relations_type.Model.widen - widen_hints - curr_wstate - joined - in - result - else - joined - in - let new_widening = - if curr_wcounter = 0 - then 1 - else pred curr_wcounter - in - Current_table.update_widening_info - current_table - kinstr - new_widening - r; - { - counter_unroll = d.counter_unroll; - value = (State_set.singleton r); - } - - end - else { d with value = states } - in - - match s.skind with - | Return _ -> - Dataflow.SUse d - | Loop _ -> - if d.counter_unroll >= AnalysisParam.slevel - then - Value_parameters.result ~once:true ~current:true - "entering loop for the first time"; - Dataflow.SUse d - | UnspecifiedSequence seq -> - CilE.start_stmt kinstr; - State_set.iter - (fun state -> check_unspecified_sequence state seq) states; - CilE.end_stmt (); - Dataflow.SUse d - | _ -> Dataflow.SUse d - end - - let doEdge s succ d = - let kinstr = Kstmt s in - let states = (d.value) in - ( Check if there are some after-annotations to verify ) - let annots_after, _specs = - Annotations.single_fold_stmt - (fun annot (annot_after,spec as acc) -> - match annot with - | Before - (User { annot_content = AStmtSpec spec' } - | AI (_,{annot_content = AStmtSpec spec' }) ) - -> - let spec = match spec with - | None -> spec' - | Some s -> Logic_utils.merge_funspec s spec'; s - in - (annot_after, Some spec) - | After - (User { annot_content = AStmtSpec _spec' } - | AI (_,{annot_content = AStmtSpec _spec' }) ) -> - CilE.warn_once - "Ignoring statement contract rooted after statement"; - acc - | After (AI (_, a) | User a) -> a :: annot_after, spec - | Before _ -> acc) - s - ([], None) - in - CilE.start_stmt kinstr; - let states = - List.fold_left - (fun acc annot -> interp_annot acc s annot) - states - annots_after - in - - ( We store the state after the execution of [s] for the callback - {Value.Record_Value_After_Callbacks}. This is done here - because we want to see the values of the variables local to the block ) - if (not (Db.Value.Record_Value_After_Callbacks.is_empty ())) && - (store_state_after_during_dataflow s succ) - then ( - let old = - try Cil_datatype.Stmt.Hashtbl.find states_after s - with Not_found -> Relations_type.Model.bottom - in - let updated = State_set.fold Relations_type.Model.join states old in - Cil_datatype.Stmt.Hashtbl.replace states_after s updated - ); - - let states = - match Kernel_function.blocks_closed_by_edge s succ with - | [] -> states - | closed_blocks -> - let block_top_addresses_of_locals = - block_top_addresses_of_locals closed_blocks - in - State_set.fold - (fun state set -> - let state = - Relations_type.Model.uninitialize_locals closed_blocks state - in - State_set.add (block_top_addresses_of_locals state) set) - states - State_set.empty; - in - CilE.end_stmt (); - { d with value = states } - - let filterStmt _stmt = true - - ( Remove all local variables and formals from table ) - let externalize return kf = - match kf.fundec with - | Declaration _ -> assert false - | Definition (fundec,_loc) -> - assert - (StmtStartData.iter - (fun k v -> - if State_set.is_empty (v.value) - then () - else (Value_parameters.fatal "sid:%d@\n%a@\n" - k - State_set.pretty (v.value))); - true); - let superpos = - Current_table.find_superposition current_table return - in - let init_state = - Current_table.find_superposition - current_table - (Kstmt (Kernel_function.find_first_stmt kf)) - in - let superpos = - let result = - match return with - | Kstmt {skind = Return (Some ({enode = Lval (Var v,_)}),_)} -> - Some v - | _ -> None - in - check_fct_postconditions ~result - kf - (State_imp.to_set init_state) - (State_imp.to_set superpos) - Normal - in - let state = State_set.join_dropping_relations superpos in - Value_parameters.feedback "Recording results for %a" - Kernel_function.pretty_name kf; - merge_current ~degenerate:false; - let ret_val = - (match return with - | Kstmt {skind = Return (Some ({enode = Lval lv}),_)} -> - offsetmap_of_lv ~with_alarms:(warn_all_quiet_mode ()) state lv - | Kstmt {skind = Return (None,_)} -> None - | _ -> assert false) - in - let state = - Relations_type.Model.clear_state_from_locals fundec state - in - let offsetmap_top_addresses_of_locals, state_top_addresses_of_locals = - top_addresses_of_locals fundec - in - let result = - (match ret_val with - | None -> ret_val - | Some ret_val -> - let r,warn = offsetmap_top_addresses_of_locals ret_val - in - if warn then warn_locals_escape_result fundec; - Some r), - state_top_addresses_of_locals state, - !bases_containing_locals - in - result - - - let doGuardOneCond stmt exp t = - if State_set.is_empty (t.value) - then Dataflow.GUnreachable - else begin - CilE.start_stmt (Kstmt stmt); - let with_alarms = warn_all_quiet_mode () in - let new_values = - State_set.fold - (fun state acc -> - let test = - eval_expr - ~with_alarms - state exp - in - CilE.set_syntactic_context - (CilE.SyBinOp (Ne, Cil.zero ~loc:exp.eloc, exp)); - let warn, _, test = - check_comparable V.singleton_zero test - in - - let do_it = - (warn && Value_parameters.UndefinedPointerComparisonPropagateAll.get ()) || - let t1 = unrollType (typeOf exp) in - if isIntegralType t1 || isPointerType t1 - then V.contains_non_zero test - else true ( TODO: a float condition is true iff != 0.0 ) - in - if do_it then - try - State_set.add - (eval_cond ~with_alarms:CilE.warn_none_mode - state {positive = true; exp = exp}) - acc - with Reduce_to_bottom -> acc - else acc) - (t.value) - State_set.empty - in - let result = - if State_set.is_empty new_values then Dataflow.GUnreachable - else Dataflow.GUse {t with value = new_values} - in - CilE.end_stmt (); - result - - end - - let doGuard stmt exp t = - let not_exp = new_exp ~loc:exp.eloc (UnOp(LNot, exp, intType)) in - let thel = - doGuardOneCond stmt exp t, doGuardOneCond stmt not_exp t - in - Separate.filter_if stmt thel -end - -let dummy_non_linear_assignment = Ki.Hashtbl.create 1 - -module Loc_hashtbl = Hashtbl.Make (Location_Bits) - -class do_non_linear_assignments = object(self) - inherit - Visitor.generic_frama_c_visitor (Project.current ()) (Cil.inplace_visit ()) - as super - val mutable current_locs = None - val mutable assigns_table = - (Ki.Hashtbl.create 17 : Location_list.t Ki.Hashtbl.t) - - method result = assigns_table - - method vstmt s = - current_locs <- None; - match s.skind with - | UnspecifiedSequence seq -> - List.iter - (fun (stmt,_,_,_,_) -> - ignore (visitCilStmt (self:>cilVisitor) stmt)) - seq; - SkipChildren ( do not visit the additional lvals ) - | _ -> super#vstmt s - - method vlval lv = - match current_locs with - None -> SkipChildren - | Some current_locs -> - begin match lv with - Mem _e, _ -> DoChildren - | Var v, NoOffset -> - let loc = Locations.loc_of_varinfo v in - ignore (Loc_hashtbl.find current_locs loc.loc); - SkipChildren - | Var _v, (Index _ | Field _) -> DoChildren - end - -( - - try - - let deps,loc = - !Value.lval_to_loc_with_deps - ~with_alarms:CilE.warn_none_mode - ~deps:Zone.bottom - current_stmt lv - in - let bits_loc = valid_enumerate_bits loc in - self#join deps; - self#join bits_loc; - SkipChildren -) - - method vcode_annot _ = SkipChildren - - method visit_addr lv = - begin match lv with - Var v, offset -> - let offset' = visitCilOffset (self :> cilVisitor) offset in - let v' = Cil.get_varinfo self#behavior v in - if offset' == offset && v == v' - then SkipChildren - else ChangeTo (Var v', offset') - | Mem e, offset -> - let e' = visitCilExpr (self :> cilVisitor) e in - let offset' = visitCilOffset (self :> cilVisitor) offset in - if offset' == offset && e == e' - then SkipChildren - else ChangeTo (Mem e', offset') - end; - - method vinst i = - match i with - | Set (lv,exp,_) -> - current_locs <- Some (Loc_hashtbl.create 7); - begin match lv with - Var _, offset -> - ignore (self#voffs offset); - | Mem e, offset -> - ignore (self#vexpr e); - ignore (self#voffs offset); - end; - ignore (self#vexpr exp); - ( TODO: do some stuff with self#current_stmt ) - SkipChildren - | _ -> SkipChildren - - method vexpr exp = - match exp.enode with - | AddrOf _lv | StartOf _lv -> - SkipChildren ( TODO: do better stuff ) - | _ -> DoChildren - -end - -let no_pretty _ _ = () - -let compute_non_linear_assignments f = - let vis = new do_non_linear_assignments in - ignore (Visitor.visitFramacFunction (vis:>Visitor.frama_c_visitor) f); - vis#result - -let compute_using_cfg kf ~call_kinstr initial_state = - match kf.fundec with - | Declaration _ -> assert false - | Definition (f,_loc) -> - (if let (_,_,variadic,_) = splitFunctionTypeVI f.svar in variadic - then raise Leaf (* Do not visit variadic bodies ) - else ) -(* PH: Removed - Properties_status.RTE_Signed_Generated.set kf true; - Properties_status.RTE_DivMod_Generated.set kf true; - Properties_status.RTE_MemAccess_Generated.set kf true; -) - begin - let f_varinfo = f.svar in - let module Computer = - Computer - (struct - let stmt_can_reach = Stmts_graph.stmt_can_reach kf - let is_natural_loop = Loop.is_natural kf - let non_linear_assignments = - try - Non_linear_assignments.find f_varinfo - with - Not_found -> - let n = compute_non_linear_assignments f in - Non_linear_assignments.add f_varinfo n; - n - let slevel = get_slevel kf - let initial_state = initial_state ( for future reference ) - end) - in - let module Compute = Dataflow.ForwardsDataFlow(Computer) in - List.iter - (function {called_kf = g} -> - if kf == g - then begin - if Value_parameters.IgnoreRecursiveCalls.get() - then begin - Value_parameters.warning ~current:true ~once:true - "ignoring recursive call during value analysis of %a (%a)" - Ast_info.pretty_vname f_varinfo - pretty_call_stack (call_stack ()); - raise Leaf - end - else - raise (Extlib.NotYetImplemented "recursive calls in value analysis") - end) - (call_stack ()); - push_call_stack {called_kf = kf; - call_site = call_kinstr; - called_merge_current = Computer.merge_current}; - match f.sbody.bstmts with - [] -> assert false - | start :: _ -> - let ret_id = Kernel_function.find_return kf in - ( We start with only the start block ) - Computer.StmtStartData.add - start.sid - (Computer.computeFirstPredecessor - start - { - Computer.counter_unroll = 0; - value = initial_state}); - begin try - Compute.compute [start] - with Db.Value.Aborted as e -> - ( State_builder.was aborted: pop the call stack and inform - the caller *) - pop_call_stack (); - raise e - end; - let last_ret,last_s,last_clob as last_state = - try - let _,state,_ as result = - try - Computer.externalize (Kstmt ret_id) kf - with Not_found -> assert false - in - if Relations_type.Model.is_reachable state - then begin - try - if hasAttribute "noreturn" f_varinfo.vattr - then - Value_parameters.warning ~current:true ~once:true - "function %a may terminate but has the noreturn attribute" - Kernel_function.pretty_name kf; - with Not_found -> assert false - end - else raise Not_found; - result - with Not_found -> begin - None, - Relations_type.Model.bottom, - Location_Bits.Top_Param.bottom - end - in - Value_parameters.debug - "@[RESULT FOR %a <-%a:@\n\\result -> %a@\n%a@\nClobered set:%a@]" - Kernel_function.pretty_name kf - pretty_call_stack (call_stack ()) - (fun fmt v -> - match v with - | None -> () - | Some v -> V_Offsetmap.pretty fmt v) - last_ret - no_pretty last_s - Location_Bits.Top_Param.pretty - last_clob; - pop_call_stack (); - last_state - end - -(** Associates [kernel_function] to a fresh base for the address returned by - the [kernel_function]. ) -module Leaf_Table = - Kernel_function.Make_Table - (Base) - (struct - let dependencies = [Db.Value.self] - let size = 7 - let name = "Leaf_Table" - let kind = `Internal - end) - -let return_value return_type kf state = - ( Process return of function ) - let return_type = unrollType return_type in - match return_type with - | TComp _ when is_fully_arithmetic return_type -> - Cvalue_type.V.top_int, state - | TPtr(typ,_) | (TComp _ as typ) -> begin - let new_base = - Leaf_Table.memo - (fun kf -> - let new_varinfo = - makeGlobalVar - ~logic:true - (Cabs2cil.fresh_global - ("alloced_return_" ^ Kernel_function.get_name kf)) - typ - in - let new_offsetmap = - Cvalue_type.V_Offsetmap.sized_zero (memory_size ()) - in - Cvalue_type.Default_offsetmap.create_initialized_var - new_varinfo - (Base.Known (Int.zero, max_bit_address ())) - new_offsetmap) - kf - in - let initial_value = - if isIntegralType typ - then Cvalue_type.V.top_int - else if isFloatingType typ - then Cvalue_type.V.top_float - else - Cvalue_type.V.inject_top_origin - (Origin.Leaf (LocationSetLattice.currentloc_singleton())) - (Cvalue_type.V.Top_Param.O.singleton new_base) - (top_leaf_origin ()) - in - let modu = try - if isVoidType typ then Int.one else Int_Base.project (osizeof typ) - with Int_Base.Error_Top -> - assert (Cvalue_type.V.is_isotropic initial_value); - Int.one - in - let returned_loc = - try - Location_Bytes.inject - new_base - (Ival.filter_ge_int (Some Int.zero) - (Ival.create_all_values - ~signed:true - ~modu - ~size:(sizeofpointer ()))) - with Int_Base.Error_Top -> - Location_Bytes.inject - new_base - Ival.top - in - let state = - Relations_type.Model.create_initial - ~base:new_base - ~v:initial_value ~modu:(Int.mul Int.eight modu) ~state - in - returned_loc, state - end - | TInt _ | TEnum _ -> Cvalue_type.V.top_int, state - | TFloat _ -> Cvalue_type.V.top_float, state - | TBuiltin_va_list _ -> - Cvalue_type.V.top_leaf_origin() - ( Only some builtins may return this type ), - state - | TVoid _ -> Cvalue_type.V.top ( this value will never be used ), state - | TFun _ | TNamed _ | TArray _ -> assert false - -exception Deref_lvals of Cil_types.lval list - -let compute_using_prototype kf ~state_with_formals = - match kf.fundec with - | Definition (_,_) -> assert false - | Declaration (_,vi,_,_) when Cil.hasAttribute "noreturn" vi.vattr -> - None, Relations_type.Model.bottom, Location_Bits.Top_Param.bottom - | Declaration (_spec,varinfo,_,_) -> - let return_type,_formals_type,_inline,_attr = - splitFunctionType (Kernel_function.get_type kf) - in - let behaviors = valid_behaviors kf state_with_formals in - let assigns = Ast_info.merge_assigns behaviors in - let returned_value, state_with_formals = - return_value return_type kf state_with_formals - in - let returned_value = ref returned_value in - let clobbered_set = ref Location_Bits.Top_Param.bottom in - let state = - match assigns with - | WritesAny -> Value_parameters.warning "Cannot handle empty assigns clause. Assuming assigns \\nothing: be aware this is probably incorrect."; - state_with_formals - | Writes [] -> state_with_formals - | Writes l -> - let treat_assign acc (out, ins) = - let input_contents = - try - match ins with - FromAny -> - ( [VP] \from \nothing has the - same meaning as unspecified \from... ) - Cvalue_type.V.top_int - | From l -> - List.fold_left - (fun acc term -> - let input_loc = - !Db.Properties.Interp.identified_term_zone_to_loc - ~result:None - state_with_formals - term - in - let r = - Relations_type.Model.find - ~conflate_bottom:true - ~with_alarms:CilE.warn_none_mode - state_with_formals - input_loc - in - ( Format.printf "loc %a r %a@." - Locations.pretty input_loc - Cvalue_type.V.pretty r; ) - Cvalue_type.V.join acc r) - Cvalue_type.V.top_int - l - with Invalid_argument "not an lvalue" -> - Value_parameters.result - ~once:true ~current:true - "cannot interpret assigns in function %a" - Kernel_function.pretty_name kf; - Cvalue_type.V.top - in - let treat_output_loc loc acc = - remember_bases_with_locals - clobbered_set - loc - input_contents; - let bound = - Relations_type.Model.add_binding - ~with_alarms:CilE.warn_none_mode - ~exact:false acc loc input_contents - in - bound - in - try - let lvals_out = - try - !Db.Properties.Interp.loc_to_lval - ~result:None - out.it_content - with - Invalid_argument "not an lvalue" as e -> - begin - match out with - {it_content= - {term_node= - TLval - (TMem - {term_node=TBinOp((IndexPI|PlusPI) , - t1,_o1)}, _o2)}} - -> - let deref_lvals = - !Db.Properties.Interp.loc_to_lval - ~result:None t1 - in - ( Format.printf "input: %a@." - Cvalue_type.V.pretty input_contents ; ) - raise (Deref_lvals deref_lvals) - | _ -> raise e - end - in - let result = - List.fold_left - (fun acc lval -> - let loc = - lval_to_loc ~with_alarms:CilE.warn_none_mode - state_with_formals lval - in - ( Format.printf "lval:%a loc:%a@." - !d_lval lval - Locations.pretty loc; ) - treat_output_loc loc acc - ) - acc - lvals_out - in - result - with - Invalid_argument "not an lvalue" -> - if Logic_utils.is_result out.it_content then begin - returned_value := - Cvalue_type.V.join - (Cvalue_type.V.topify_arith_origin - input_contents) - !returned_value; - acc - end else begin - Value_parameters.warning ~once:true ~current:true - "Can not interpret assigns in function %a; \ - effects will be ignored" - Kernel_function.pretty_name kf; acc - end - | Deref_lvals deref_lvals -> - let deref_loc = - List.fold_left - (fun acc lv -> - Location_Bits.join - (lval_to_loc ~with_alarms:CilE.warn_none_mode - state_with_formals lv).loc - acc) - Location_Bits.bottom - deref_lvals - in - let deref_loc = Location_Bits.topify_arith_origin deref_loc - in - let loc_bytes = - Relations_type.Model.find - ~conflate_bottom:true - ~with_alarms:CilE.warn_none_mode - state_with_formals - (make_loc deref_loc Int_Base.top) - in - let loc = - make_loc (loc_bytes_to_loc_bits loc_bytes) Int_Base.top - in - treat_output_loc loc acc - in - (List.fold_left treat_assign state_with_formals l) - in - let retres_vi, state = - if isVoidType return_type - then None, state - else - let offsetmap = - V_Offsetmap.update_ival - ~with_alarms:CilE.warn_none_mode - ~validity:Base.All - ~offsets:Ival.zero - ~exact:true - ~size:(Int.of_int (bitsSizeOf return_type)) - V_Offsetmap.empty - (Cvalue_type.V_Or_Uninitialized.initialized !returned_value) - in - Library_functions.add_retres_to_state - varinfo - offsetmap - state - in - retres_vi, state, !clobbered_set - - -( Replace in [initial_state] all keys in [mem_outs] by their value in - [mem_final_state]. ) -let compute_using_mem - _kf - (initial_state:Relations_type.Model.t) - (new_return_v,mem_final_state) - mem_outs - instanciation = - let (a,clobbered_bases) = - Relations_type.Model.compute_actual_final_from_generic - initial_state - mem_final_state - mem_outs - instanciation - in - (TODO: new_return_v MUST be substituted! *) - new_return_v,a,clobbered_bases - - -(** Compute only once the initial values for globals and NULL ) -let initial_state_contextfree_only_globals = - let module S = - State_builder.Option_ref - (Relations_type.Model) - (struct - let name = "contextfree_only_globals" - let dependencies = - [ Ast.self; Parameters.LibEntry.self; Parameters.MainFunction.self ] - let kind = `Internal - end) - in - function () -> - let add_varinfo state varinfo = - CurrentLoc.set varinfo.vdecl; - initialize_var_using_type varinfo state - in - let treat_global state = function - | GVar(vi,_,_) -> add_varinfo state vi - | GVarDecl(_,vi,_) when not (Cil.isFunctionType vi.vtype) -> - add_varinfo state vi - | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ - | GVarDecl _ | GFun _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> state - in - let compute () = - List.fold_left treat_global (initial_state_only_globals()) - (Ast.get ()).globals - in - S.memo compute - -let initial_state_formals kf (state:Relations_type.Model.t) = - match kf.fundec with - | Declaration _ -> assert false - | Definition (f,_) -> - List.fold_right - initialize_var_using_type - f.sformals - state - -let rec fold_left2_best_effort f acc l1 l2 = - match l1,l2 with - | _,[] -> acc - | [],_ -> - Value_parameters.result ~once:true ~current:true - "not enough arguments in function call."; - acc - | (x1::r1),(x2::r2) -> fold_left2_best_effort f (f acc x1 x2) r1 r2 - -let actualize_formals kf state actuals = - let formals = Kernel_function.get_formals kf in - let treat_one_formal acc (_,_actual_val,actual_o) formal = - let loc_without_size = - Location_Bits.inject - (Base.create_varinfo formal) - (Ival.zero) - in - Relations_type.Model.paste_offsetmap - actual_o - loc_without_size - Int.zero - (Int_Base.project (sizeof_vid formal)) - acc - in - fold_left2_best_effort - treat_one_formal - state - actuals - formals - -( In the state [initial_state] globals and formals are present - but locals of [kf] are not.) -let compute_with_initial_state kf initial_state = - match kf.fundec with - | Declaration _ -> assert false - | Definition (f,_) -> - let initial_state = - List.fold_left - (fun acc local -> - Relations_type.Model.add_binding_unspecified - acc - (Locations.loc_of_varinfo local)) - initial_state - f.slocals - in - let initial_state = check_fct_preconditions kf initial_state in - compute_using_cfg kf initial_state - -let compute_entry_point kf ~library = - clear_call_stack (); - Kf_state.mark_as_called kf; - Value_parameters.feedback "Analyzing a%scomplete application starting at %a" - (if library then "n in" else " ") - Kernel_function.pretty_name kf; - - Separate.prologue(); - - let initial_state_globals = - if Db.Value.globals_use_supplied_state () then ( - let r = Db.Value.globals_state () in - Value_parameters.feedback "Initial state supplied by user"; - Value_parameters.debug "@[<hov 0>Values of globals@\n%a@]" - Db.Value.pretty_state_without_null r; - r) - else ( - Value_parameters.feedback "Computing initial state"; - let r = Db.Value.globals_state () in - Value_parameters.feedback "Initial state computed"; - Value_parameters.result - "@[<hov 0>Values of globals at initialization@\n%a@]" - Db.Value.pretty_state_without_null r; - r - ) in - Db.Value.update_table Kglobal initial_state_globals; - - Mark_noresults.run(); - - let with_formals = match Db.Value.fun_get_args () with - | None -> initial_state_formals kf initial_state_globals - | Some actuals -> - let formals = Kernel_function.get_formals kf in - if (List.length formals) <> List.length actuals then - raise Db.Value.Incorrect_number_of_arguments; - let treat_one_formal f a = - (), a, Builtins.offsetmap_of_value ~typ:f.vtype a - in - actualize_formals - kf - initial_state_globals - (List.map2 treat_one_formal formals actuals) - in - Db.Value.Call_Value_Callbacks.apply (with_formals, [ kf, Kglobal ]); - let result = - compute_with_initial_state kf ~call_kinstr:Kglobal with_formals - in - Value_parameters.feedback "done for function %a" - Kernel_function.pretty_name kf; - Separate.epilogue(); - result - -exception Not_modular -exception Invalid_CEA_alloc -exception Invalid_CEA_memcpy - -module Mem_Exec = - Kernel_function.Make_Table - (Datatype.Make - (struct - include Datatype.Undefined - type t = - Relations_type.Model.t - (V_Offsetmap.t option * Relations_type.Model.t) - * Locations.Zone.t (* in ) - Locations.Zone.t (* out ) - let name = "Mem_Exec" - let reprs = - List.fold_left - (fun acc m -> - List.fold_left - (fun acc o -> - List.fold_left - (fun acc z -> (m, (Some o, m), z, z) :: acc) - acc - Locations.Zone.reprs) - acc - V_Offsetmap.reprs) - [] - Relations_type.Model.reprs - end)) - (struct - let name = "Mem_Exec" - let size = 7 - let dependencies = [ Db.Value.self ] - let kind = `Internal - end) - - -let compute_call kf ~call_kinstr - (initial_state:Relations_type.Model.t) actuals = - let initial_state = Relations_type.Model.drop_relations initial_state in - let with_formals = actualize_formals kf initial_state actuals in - Db.Value.merge_initial_state kf with_formals; - let stack_without_call = for_callbacks_stack () in - Db.Value.Call_Value_Callbacks.apply - (with_formals, ((kf, call_kinstr) :: stack_without_call)); - let name = Kernel_function.get_name kf in - ( function whose name starts with 'CEA_' - print their arguments on stdout during computations.) - let result = - if Ast_info.is_cea_dump_function name then begin - let l = fst (CurrentLoc.get ()) in - Value_parameters.result - "DUMPING STATE of file %s line %d@\n%a=END OF DUMP==" - l.Lexing.pos_fname l.Lexing.pos_lnum - Relations_type.Model.pretty initial_state; - None, initial_state, Location_Bits.Top_Param.bottom - end - else - try - let abstract_function = Builtins.find_builtin name in - abstract_function initial_state actuals - with Not_found -> - if Ast_info.is_cea_alloc_with_validity name then begin - try - let size = match actuals with - | [_,size,_] -> size - | _ -> raise Invalid_CEA_alloc - in - let size = - try - let size = Cvalue_type.V.project_ival size in - Ival.project_int size - with Ival.Not_Singleton_Int | V.Not_based_on_null -> - raise Invalid_CEA_alloc - in - if Int.le size Int.zero then raise Invalid_CEA_alloc; - let new_name = - Format.sprintf "Frama_C_alloc" - in - let new_name = Cabs2cil.fresh_global new_name in - let bounded_type = - TArray( - charType, - Some (new_exp ~loc:Cil_datatype.Location.unknown - (Const (CInt64 (Int.to_int64 size,IInt ,None)))), - empty_size_cache (), - []) - in - let new_varinfo = - makeGlobalVar ~logic:true new_name bounded_type - in - let size_in_bits = Int.mul (sizeofchar()) size in - let new_offsetmap = - Cvalue_type.V_Offsetmap.sized_zero ~size_in_bits - in - let new_base = - Cvalue_type.Default_offsetmap.create_initialized_var - new_varinfo - (Base.Known (Int.zero, Int.pred size_in_bits)) - new_offsetmap - in - let loc_without_size = Location_Bytes.inject new_base Ival.zero in - ( Hashtbl.add dynamic_alloc_table file loc_without_size; ) - (Builtins.wrap_ptr loc_without_size),initial_state, Location_Bits.Top_Param.bottom - with Ival.Error_Top | Invalid_CEA_alloc - | Not_found ( from [find_lonely_key]) - -> - Value_parameters.error - "Invalid argument for Frama_C_alloc_size function"; - do_degenerate None; - raise Db.Value.Aborted - end else if Ast_info.is_cea_function name then begin - Value_parameters.result "Called %s%a" - name - pretty_actuals - actuals; - None,initial_state, Location_Bits.Top_Param.bottom - end - else begin - let function_name = Kernel_function.get_name kf in - Value_parameters.feedback - "computing for function %a <-%a.@\nCalled from %a." - !Ast_printer.d_ident function_name - pretty_call_stack (call_stack ()) - pretty_loc_simply - (CilE.current_stmt()); - Kf_state.mark_as_called kf; - let modular = - Value_parameters.MemExecAll.get () - || Datatype.String.Set.mem name (Value_parameters.MemFunctions.get ()) - in - let result = - match kf.fundec with - | Definition _ -> - begin try - if not modular then raise Not_modular; - let mem_initial_state, mem_final_state, mem_in, mem_outs = - !Db.Value.memoize kf; - try Mem_Exec.find kf with Not_found -> raise Not_modular - in - try - let instanciation = - Relations_type.Model.is_included_actual_generic - (Zone.join mem_in mem_outs) - with_formals - mem_initial_state - in - Value_parameters.result ~current:true "Instanciation succeeded: %a" - (let module M = Base.Map.Make(Location_Bytes) in - M.pretty) - instanciation; - compute_using_mem kf - initial_state - mem_final_state - mem_outs - instanciation - with Is_not_included -> - Value_parameters.result ~current:true ~once:true - "Failed to see context as an instance of the generic context: inlining call to %a." - Kernel_function.pretty_name kf; - raise Not_modular - with Not_modular -> - compute_with_initial_state kf ~call_kinstr with_formals - end - | Declaration (_,_varinfo,_,_) -> - let stateset = check_fct_preconditions kf with_formals in - ( TODO: This is a hack. Use a function that checks preconditions - without multiplying the states instead -- or - compute_using_prototype several times ) - let state_with_formals = State_set.join stateset in - let retres_vi, result_state, thing = - compute_using_prototype kf ~state_with_formals in - let result_state = - check_fct_postconditions ~result:retres_vi kf - (State_set.singleton state_with_formals) - (State_set.singleton result_state) - Normal - in - let result_state = State_set.join result_state in - let result, retres = - match retres_vi with - None -> None, None - | Some vi -> - let value_state = - Relations_type.Model.value_state result_state - in - let retres_base = Base.create_varinfo vi in - Some - (Cvalue_type.Model.find_base - retres_base - value_state), - (Some retres_base) - in - let formals = Kernel_function.get_formals kf in - let result_state = - List.fold_left - (fun acc vi -> - Relations_type.Model.remove_base - (Base.create_varinfo vi) - acc) - result_state - formals - in - let result_state = - match retres with - Some retres -> - Relations_type.Model.remove_base retres result_state - | None -> result_state - in - result, result_state, thing - in - Value_parameters.feedback "Done for function %a" - Kernel_function.pretty_name kf; - result - end - in - result - -let memoize kf = - try - ignore - (Mem_Exec.memo - (fun kf -> - Kf_state.mark_as_called kf; - let with_globals = initial_state_contextfree_only_globals () in - let with_formals = initial_state_formals kf with_globals in - let (a,b,_) = - compute_with_initial_state kf ~call_kinstr:Kglobal with_formals - in - let result = a,b in - let ins = - (!Db.InOutContext.get_internal kf).Inout_type.over_inputs - in - let outs = !Db.Outputs.get_external kf in - with_formals,result,ins,outs) - kf) - with Db.Value.Aborted -> - ( the function will not be memoized. TODO: inform the user - that the analyzer will behave as if the option was not set ) - () - -let force_compute () = - ( check floats ) - let u = min_float /. 2. in - let u = u /. 2. in - assert (0. < u && u < min_float); - try - let kf, library = Globals.entry_point () in - ignore (compute_entry_point kf ~library); - ( Move all alarms to Db ) - Db.Properties.synchronize_alarms [ Db.Value.self ]; - Db.Value.mark_as_computed (); - ( Cleanup trivially redundant alarms ) - !Db.Scope.rm_asserts () - with - | Db.Value.Aborted -> - ( This case is reached only if [do_degenerate] did not raise another - exception to handle abortion properly. See the behavior of the GUI - in case of degeneration to understand the machinery. ) - Db.Value.mark_as_computed (); - Value_parameters.abort - "Degeneration occured:@\nresults are not correct for lines of code \ -that can be reached from the degeneration point." - | Globals.No_such_entry_point _ as exn -> raise exn - | exn -> Db.Value.mark_as_computed (); raise exn - -let () = compute_call_ref := compute_call - -let _self = - Db.register_compute "Value.compute" - [ Db.Value.self ] - Db.Value.compute - (fun () -> if not (Db.Value.is_computed ()) then force_compute ()) - -let () = Db.Value.memoize := memoize -let () = Db.Value.initial_state_only_globals := - (fun () -> if snd(Globals.entry_point ()) then - initial_state_contextfree_only_globals () - else - initial_state_only_globals () - ) -let () = Db.Value.find_lv_plus := find_lv_plus -let () = Db.Value.eval_expr_with_state := - (fun ~with_alarms state expr -> - let (s,_,v) = eval_expr_with_deps_state ~with_alarms None state expr in - s,v) - -( -Local Variables: -compile-command: "make -C ../.." -End: -*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval.mli frama-c-20111001+nitrogen+dfsg/src/value/eval.mli --- frama-c-20110201+carbon+dfsg/src/value/eval.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -(**************************************************************************) -(* ) -( This file is part of Frama-C. ) -( ) -( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( ) -( you can redistribute it and/or modify it under the terms of the GNU ) -( Lesser General Public License as published by the Free Software ) -( Foundation, version 2.1. ) -( ) -( It 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 Lesser General Public License for more details. ) -( ) -( See the GNU Lesser General Public License version 2.1 ) -( for more details (enclosed in the file licenses/LGPLv2.1). ) -( *) -(**************************************************************************) - -val eval_lval : - conflate_bottom:bool -> - with_alarms:CilE.warn_mode -> - Locations.Zone.t option -> - Db.Value.state -> - Cil_types.lval -> - Db.Value.state * Locations.Zone.t option * Cvalue_type.V.t - -val eval_expr : - with_alarms:CilE.warn_mode -> - Db.Value.state -> Cil_types.exp -> Cvalue_type.V.t - -val lval_to_loc_with_deps : - deps:Locations.Zone.t -> - Db.Value.state -> - Cil_types.lval -> - with_alarms:CilE.warn_mode -> - reduce_valid_index:bool -> - Db.Value.state * Locations.Zone.t option * Locations.location - -val lval_to_loc : - with_alarms:CilE.warn_mode -> - Db.Value.state -> Cil_types.lval -> Locations.location - -val resolv_func_vinfo : - with_alarms:CilE.warn_mode -> - Locations.Zone.t option -> - Db.Value.state -> - Cil_types.exp -> Locations.Zone.t option * Kernel_function.Hptset.t - -exception Leaf - -(* -Local Variables: -compile-command: "make -C ../.." -End: -*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/eval_stmts.ml frama-c-20111001+nitrogen+dfsg/src/value/eval_stmts.ml --- frama-c-20110201+carbon+dfsg/src/value/eval_stmts.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/eval_stmts.ml 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,1406 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Value analysis of statements and functions bodies ) + +open Cil_types +open Cil +open Cil_datatype +open Locations +open Abstract_interp +open Bit_utils +open Cvalue +open Ast_printer +open Value_util +open Eval_exprs +open Eval_logic +open Locals_scoping + +exception Wrong_function_type ( in function call ) + +let need_cast t1 t2 = + match unrollType t1, unrollType t2 with + | (TInt _| TEnum _| TPtr _), (TInt _| TEnum _| TPtr _) + | TFloat _, TFloat _ + | TComp _, TComp _ -> + (try bitsSizeOf t1 <> bitsSizeOf t2 + with SizeOfError _ -> true) + | _ -> true + +let offsetmap_of_lv ~with_alarms state lv = + CilE.set_syntactic_context (CilE.SyMem lv); + let loc_to_read = + lval_to_loc ~with_alarms state lv + in + Cvalue.Model.copy_offsetmap + ~with_alarms:CilE.warn_none_mode + loc_to_read + state + +exception Got_bottom + +let compute_actual ~with_alarms (one_library_fun, all_library_funs) state e = + let interpreted_expr, o = match e with + | { enode = Lval l } + when ( make sure not a bit-field ) not (is_bitfield l ()) -> + let _, _, interpreted_expr = + eval_lval ~conflate_bottom:false ~with_alarms None state l + in + if one_library_fun then + ignore (eval_lval ~conflate_bottom:true ~with_alarms None state l); + if V.is_bottom interpreted_expr + then begin + if not one_library_fun then ( alarm ) + ignore (eval_lval ~conflate_bottom:true ~with_alarms None state l); + if all_library_funs + then begin + Value_parameters.result ~current:true + "Non-termination@ in@ evaluation@ of@ library function@ call@ lvalue@ argument@ @[%a@]" (!d_lval) l; + end; + raise Got_bottom; + end; + let r = do_cast ~with_alarms (typeOf e) interpreted_expr in + let o = offsetmap_of_lv ~with_alarms state l in + (match o with + | Some o -> r, o + | None -> + Format.printf "failure in evaluation of function arguments@\n\ + lval %a -> %a@." !d_lval l V.pretty interpreted_expr; + assert false) + | _ -> + let interpreted_expr = eval_expr ~with_alarms state e in + if V.is_bottom interpreted_expr + then begin + Value_parameters.result ~current:true + "Non-termination@ in@ evaluation@ of@ function@ call@ expression@ argument@ @[%a@]" + (!d_exp) e; + raise Got_bottom + end; + let typ = Cil.typeOf e in + interpreted_expr, + Builtins.offsetmap_of_value ~typ interpreted_expr + in + e, interpreted_expr, o + + +( Forward reference to {Eval_calls.compute_call} ) +let compute_call_ref = ref (fun _ -> assert false) + +module Computer + (AnalysisParam:sig + val stmt_can_reach : stmt -> stmt -> bool + val is_natural_loop : stmt -> bool + val slevel: int + val initial_state : State_set.t + val active_behaviors: Eval_logic.ActiveBehaviors.t + end) = + +struct + let debug = ref false + let name = "Values analysis" + + let stmt_can_reach = AnalysisParam.stmt_can_reach + + let obviously_terminates = + Value_parameters.ObviouslyTerminatesAll.get() ( TODO: by function ) + + let slevel = + if obviously_terminates + then max_int + else + AnalysisParam.slevel + + let debug = ref false + + let fused_initial_state = lazy (State_set.join AnalysisParam.initial_state) + + let current_table = Current_table.create () + + let states_after = Cil_datatype.Stmt.Hashtbl.create 5 + + ( During the dataflow analysis, if required by a callback, we store the + state after a statement, but only if the following conditions are met + ([succ] being a successor of [s]) + - if [s] is an instr (which almost always change the state, unlike + the other kind of statements) + - if there is a control-flow join on [succ] + - if [s] is the last instruction of a block that contains + local variables + For statements for which the function below returns false, we deduce + the state after by the state before [succ] or another successor of [s]. + This avoids potentially useless computations + ) + let store_state_after_during_dataflow s succ = + ((match s.skind with Instr _ -> true | _ -> false) && + (match succ.preds with [_] -> false | _ -> true)) + || (let b1 = Kernel_function.find_enclosing_block s + and b2 = Kernel_function.find_enclosing_block succ in + not (Cil_datatype.Block.equal b1 b2) && b1.blocals <> []) + + ( Computation of the per-function 'after statement' states ) + let local_after_states superposed = + lazy ( + let superposed = Lazy.force superposed in + Stmt.Hashtbl.iter + (fun stmt state -> + List.iter + (fun pred -> + if not (store_state_after_during_dataflow pred stmt) then + try + let cur = Stmt.Hashtbl.find states_after pred in + Stmt.Hashtbl.replace states_after pred + (Cvalue.Model.join state cur) + with Not_found -> Stmt.Hashtbl.add states_after pred state + ) stmt.preds; + ) superposed; + ( Since the return instruction has no successor, it is not visited + by the iter above. We fill it manually ) + (try + let ret = Kernel_function.find_return (current_kf ()) in + let s = Stmt.Hashtbl.find superposed ret in + Stmt.Hashtbl.add states_after ret s + with Kernel_function.No_Statement | Not_found -> () + ); + states_after + ) + + ( Merging of 'after statement' states in the global table ) + let merge_after after_full = + Cil_datatype.Stmt.Hashtbl.iter + (fun stmt st -> + try + let prev = Db.Value.AfterTable.find stmt in + Db.Value.AfterTable.replace stmt (Cvalue.Model.join prev st) + with Not_found -> + Db.Value.AfterTable.add stmt st + ) (Lazy.force after_full) + + ( Table storing whether conditions on 'if' have been evaluated + to true or false ) + let conditions_table = Cil_datatype.Stmt.Hashtbl.create 5 + + let merge_current ~degenerate = + let superposed = lazy (Current_table.states current_table) in + let after_full = local_after_states superposed in + Current_table.merge_db_table superposed; + Db.Value.merge_conditions conditions_table; + if Value_parameters.ResultsAfter.get () then merge_after after_full; + if not degenerate then begin + let stack_for_callbacks = for_callbacks_stack () in + + if not (Db.Value.Record_Value_Superposition_Callbacks.is_empty ()) + then begin + let current_superpositions = + lazy (Current_table.superpositions current_table) + in + if Value_parameters.ValShowProgress.get() then + Value_parameters.feedback + "now calling Record_Value_Superposition callbacks"; + Db.Value.Record_Value_Superposition_Callbacks.apply + (stack_for_callbacks, current_superpositions); + end ; + + if not (Db.Value.Record_Value_Callbacks.is_empty ()) + then begin + if Value_parameters.ValShowProgress.get() then + Value_parameters.feedback "now calling Record_Value callbacks"; + Db.Value.Record_Value_Callbacks.apply + (stack_for_callbacks, superposed) + end; + + if not (Db.Value.Record_Value_After_Callbacks.is_empty ()) + then begin + if Value_parameters.ValShowProgress.get() then + Value_parameters.feedback "now calling Record_After_Value callbacks"; + Db.Value.Record_Value_After_Callbacks.apply + (stack_for_callbacks, after_full); + end; + + end; + Current_table.clear current_table + + type u = + { counter_unroll : int; ( how many times this state has been crossed *) + mutable value : State_set.t ; } + + module StmtStartData = + Dataflow.StartData(struct type t = u let size = 107 end) + + type t = u + + let copy (d: t) = d + + let display_one fmt v = + State_set.iter (fun value -> + if not (Cvalue.Model.is_reachable value) then + Format.fprintf fmt "Statement (x%d): UNREACHABLE@\n" v.counter_unroll + else + Format.fprintf fmt "Statement (x%d)@\n%a" + v.counter_unroll + Cvalue.Model.pretty + value) + v.value + + let pretty fmt (d: t) = display_one fmt d + + let computeFirstPredecessor (_s: stmt) state = + { counter_unroll = 0; value = state.value;} + + let getWidenHints (s: stmt) = + Widen.getWidenHints (current_kf()) s + + let counter_unroll_target = ref 100 + + let combinePredecessors (_s: stmt) ~old new_ = + if State_set.is_empty (new_.value) + then None + else begin + if old.counter_unroll >= slevel + then + let sum = + Cvalue.Model.join + (State_set.join new_.value) + (State_set.join old.value) + in + Some {counter_unroll = old.counter_unroll ; + value = State_set.singleton sum;} + else begin try + let merged = State_set.merge_into new_.value old.value in + let length_new = State_set.length new_.value in + let new_counter_unroll = old.counter_unroll + length_new in + if new_counter_unroll >= !counter_unroll_target + then begin + Value_parameters.result ~once:true + "Semantic level unrolling superposing up to %d states" + !counter_unroll_target; + counter_unroll_target := !counter_unroll_target + 100; + end; + let result = + Some + { value = merged ; + counter_unroll = new_counter_unroll } + in + result + with State_set.Unchanged -> None + end + end + + (** Clobber list for bases containing addresses of local variables. *) + let bases_containing_locals = ref Location_Bits.Top_Param.bottom + let remember_bases_with_locals = + remember_bases_with_locals bases_containing_locals + +(** Precondition: the type of [exp] and the type [loc_lv] may be different + only if the cast from [typeOf exp] and [typeOf loc_lv] is a truncation + or an extension. + This function will not perform any conversion (float->int, int->float, ...) + [exp] should not be bottom for optimization purposes in the caller. + ) + let do_assign_abstract_value_to_loc ~with_alarms state lv loc_lv exp = + assert (not (Cvalue.V.is_bottom exp)); + ( Or one may propagate bottoms uselessly for too long. ) + let exp = ( truncate the value if the [lv] is too small: this may + happen when the [lv] is a bit-field. Otherwise, the + cast is explicit thanks to Cil and no truncation is + necessary. ) + try + ( if it is a bit-field, the size is statically known. ) + let size = Int_Base.project loc_lv.size in + try + ignore (V.project_ival exp); + cast_lval_bitfield lv size exp + with + | V.Not_based_on_null ( from [project_ival] ) -> + ( The exp is a pointer: check there are enough bits in + the bit-field to contain it. ) + if Int.compare size (Int.of_int (sizeofpointer ())) >= 0 + || V.is_imprecise exp + then exp + else begin + Value_parameters.result + "casting address to a bit-field of %s bits: this is smaller than sizeof(void)" + (Int.to_string size); + V.topify_arith_origin exp + end + | Neither_Int_Nor_Enum_Nor_Pointer + (* from [signof_typeof_lval] ) -> exp + with + | Int_Base.Error_Top | Int_Base.Error_Bottom -> + ( from [project]: size is not known ) + exp + in + let pretty_org fmt org = if not (Origin.is_top org) then + Format.fprintf fmt " because of %a" Origin.pretty org + in + (match loc_lv.loc with + | Location_Bits.Top (Location_Bits.Top_Param.Top, orig) -> + Value_parameters.result + "State before degeneration:@\n======%a@\n=======" + Cvalue.Model.pretty state; + warning_once_current + "writing at a completely unknown address@[%a@].@\nAborting." + pretty_org orig; + do_degenerate (Some lv) + + | Location_Bits.Top((Location_Bits.Top_Param.Set _) as param,orig) -> + Value_parameters.result ~current:true ~once:true + "writing somewhere in @[%a@]@[%a@]." + Location_Bits.Top_Param.pretty param + pretty_org orig + | Location_Bits.Map _ -> ( everything is normal *) ()); + let exact = valid_cardinal_zero_or_one ~for_writing:true loc_lv in + let value = + Cvalue.Model.add_binding ~with_alarms ~exact + state loc_lv exp + in + value + + (** Precondition: the type of [exp] and the type [loc_lv] may be different + only if the cast from [typeOf exp] + and [typeOfPointed lv] is a truncation or an extension. + This function will not perform any conversion (float->int, int->float,..) + ) + let do_assign_abstract_value ~with_alarms state lv exp = + let loc_lv = lval_to_loc ~with_alarms state lv in + remember_bases_with_locals loc_lv exp; + CilE.set_syntactic_context (CilE.SyMem lv); + do_assign_abstract_value_to_loc ~with_alarms state lv loc_lv exp + + + let offsetmap_top_addresses_of_locals is_local = + let is_local_bytes = Location_Bytes.contains_addresses_of_locals is_local in + fun offsetmap -> + if Cvalue.V_Offsetmap.is_empty offsetmap + then Location_Bytes.Top_Param.top, offsetmap + else + let loc_contains_addresses_of_locals t = + let v = Cvalue.V_Or_Uninitialized.get_v t in + is_local_bytes v + in + let locals, result = + Cvalue.V_Offsetmap.top_stuff + loc_contains_addresses_of_locals + (fun v -> + Cvalue.V_Or_Uninitialized.unspecify_escaping_locals + is_local v) + Location_Bytes.Top_Param.join + Location_Bytes.Top_Param.bottom + offsetmap + in + locals, result + + let state_top_addresses_of_locals ~is_block offsetmap_top_addresses_of_locals fundec = + let f k offsm = + let locals, r = offsetmap_top_addresses_of_locals offsm in + let found_locals = not (Cvalue.V_Offsetmap.equal r offsm) in + if found_locals then + warn_locals_escape is_block fundec k locals; + r + in + (fun (state:Cvalue.Model.t) -> + ( let's forget relations ) + let simple_state = state in + let f base acc = + try + let offset_to_clean = Cvalue.Model.find_base base simple_state + in + let cleaned_offsetmap = f base offset_to_clean in + Cvalue.Model.add_offsetmap base cleaned_offsetmap acc + with Not_found -> acc + in + try + (Location_Bits.Top_Param.fold + f + !bases_containing_locals + (f Base.null simple_state)) + with Location_Bits.Top_Param.Error_Top -> + begin + let f k offsm acc = + let locals, r = offsetmap_top_addresses_of_locals offsm in + let found_locals = not (Cvalue.V_Offsetmap.equal r offsm) in + if found_locals then + warn_locals_escape is_block fundec k locals; + Cvalue.Model.add_offsetmap k r acc + in + let result = + try + (Cvalue.Model.fold_base_offsetmap + f + state + Cvalue.Model.empty_map) + with Cvalue.Model.Error_Bottom -> Cvalue.Model.bottom + in + result + end) + + let top_addresses_of_locals fundec = + let entry_point = Globals.entry_point () in + if snd entry_point ( lib ) || + current_kf() != fst entry_point ( not entry point ) + then + let offsetmap_top_addresses_of_locals = + offsetmap_top_addresses_of_locals + (Cilutil.swap Base.is_formal_or_local fundec) + in + let state_top_addresses_of_locals = + state_top_addresses_of_locals ~is_block:false + offsetmap_top_addresses_of_locals fundec + in + offsetmap_top_addresses_of_locals, state_top_addresses_of_locals + else (fun x -> Location_Bytes.Top_Param.bottom, x),(fun x -> x) + + let block_top_addresses_of_locals blocks = + if List.for_all (fun b -> List.for_all (fun v -> v.vgenerated) b.blocals) + blocks + then + fun x -> x ( no need to change the state if there is no local + variable or if all the variable have been generated + by Cil (in which case we know that they are correctly + initialized and used, don't we) + ) + else + let offsetmap_top_addresses_of_locals = + offsetmap_top_addresses_of_locals + (fun v -> List.exists (Base.is_block_local v) blocks) + in + let state_top_addresses_of_locals = + state_top_addresses_of_locals ~is_block:true + offsetmap_top_addresses_of_locals + (Kernel_function.get_definition (current_kf())) + in + state_top_addresses_of_locals + + ( Assigns [exp] to [lv] in [state] ) + let do_assign ~with_alarms old_state lv exp = + assert (Cvalue.Model.is_reachable old_state); + let fresh_flags () = + let flag = ref false in + (fun () -> flag := true), + fun () -> !flag + in + let set_alarm, get_alarm = fresh_flags () in + let logger v = + if v <> CilE.Aignore + then CilE.Acall set_alarm + else CilE.Aignore + in + let warn_remember_mode = + { CilE.imprecision_tracing = logger with_alarms.CilE.imprecision_tracing; + others = with_alarms.CilE.others; + unspecified = logger with_alarms.CilE.unspecified} + in + let reduced_state, _, evaled_exp = + eval_expr_with_deps_state_subdiv ~with_alarms:warn_remember_mode None + old_state + exp + in +( Value_parameters.debug ~level:2 "do_assign %a = (%a)(%a)" + !d_lval lv + !d_exp exp + V.pretty evaled_exp; ) + let left_loc = lval_to_loc ~with_alarms old_state lv in + let is_bitfield = is_bitfield lv ~sizebf:left_loc.size () in + remember_bases_with_locals left_loc evaled_exp; + let warn_right_exp_imprecision () = + (match with_alarms.CilE.imprecision_tracing with + | CilE.Aignore -> () + | CilE.Acall f -> f () + | CilE.Alog _ -> + match evaled_exp with + | Cvalue.V.Top(_topparam,origin) -> + Value_parameters.result ~once:true ~current:true + "@[<v>@[Assigning imprecise value to %a%t.@]%a%t@]" + !Ast_printer.d_lval lv + (fun fmt -> match lv with + | (Mem _, _) -> + Format.fprintf fmt "@ (i.e. %a)" + Locations.pretty left_loc + | (Var _, _) -> ()) + (fun fmt org -> + if not (Origin.is_top origin) then + Format.fprintf fmt + "@ @[The imprecision@ originates@ from@ %a@]" + Origin.pretty org) + origin + pp_callstack + | Cvalue.V.Map _ -> + if not (Got_Imprecise_Value.get ()) && + not (Cvalue.V.cardinal_zero_or_one evaled_exp) + then begin + Got_Imprecise_Value.set true; + if (Value_parameters.ValShowProgress.get()) + then + Value_parameters.result ~current:true + "assigning non deterministic value for the first time"; + end) + in + let reduced_state = + match lv with + | Mem mem_e,NoOffset -> + let new_reduced_state = + reduce_by_valid_expr + ~positive:true ~for_writing:true + mem_e + reduced_state + in + if not (Cvalue.Model.is_reachable new_reduced_state) + then begin + CilE.set_syntactic_context (CilE.SyMem lv); + CilE.warn_mem_write with_alarms ; + Value_parameters.result ~current:true + "all target addresses were invalid. This path is assumed to be dead."; + end; + new_reduced_state + ( | Var _ , Index _ -> assert false + TODO: do something for "TAB[i] = expr" + ) + | _ -> reduced_state + in + let default () = + warn_right_exp_imprecision (); + if get_alarm() then + ( log alarms that have not been logged the first time ) + ignore + (eval_expr + ~with_alarms: + {CilE.imprecision_tracing=with_alarms.CilE.imprecision_tracing; + others=CilE.Aignore; + unspecified=with_alarms.CilE.unspecified} + old_state + exp); + + if Cvalue.V.is_bottom evaled_exp || + Location_Bits.equal left_loc.loc Location_Bits.bottom || + not (Cvalue.Model.is_reachable reduced_state) + then Cvalue.Model.bottom + else begin + CilE.set_syntactic_context (CilE.SyMem lv); + do_assign_abstract_value_to_loc ~with_alarms + reduced_state + lv + left_loc + evaled_exp + end + in + let default_lval exp_lv = + ( directly copy the old value without trying to recompose it. + Useful for structs assignment. ) + let right_loc = lval_to_loc ~with_alarms old_state exp_lv in + ( match right_loc.size, left_loc.size with + Int_Base.Value rsize, Int_Base.Value lsize when + Int.equal rsize lsize && + Int.to_int(rsize) > bitsSizeOf (TInt (IInt, [])) -> + if + Location_Bits.partially_overlaps + rsize + right_loc.loc + left_loc.loc + then begin + warning_once_current "Partially overlapping lvalue assignment \"%a=%a;\". Left address in bits: %a. Right address in bits: %a. assert(separated or same)" + !d_lval lv + !d_lval exp_lv + Location_Bits.pretty left_loc.loc + Location_Bits.pretty right_loc.loc; + CilE.stop_if_stop_at_first_alarm_mode () + end + | _ -> () ); + + + CilE.set_syntactic_context (CilE.SyMem exp_lv); + let full_val = + Cvalue.Model.find_unspecified + ~with_alarms:CilE.warn_none_mode + old_state + right_loc + in + if Location_Bits.equal left_loc.loc Location_Bits.bottom || + not (Cvalue.Model.is_reachable reduced_state) || + V_Or_Uninitialized.equal full_val V_Or_Uninitialized.bottom + then Cvalue.Model.bottom + else begin + match right_loc.size, left_loc.size with + | Int_Base.Value size, Int_Base.Value other_size + when Int.equal other_size size -> + let offsetmap_relations = + Cvalue.V_Offsetmap.empty ( TODO: cleanup ) + in + CilE.set_syntactic_context (CilE.SyMem exp_lv); + let offsetmap_memory = + match Cvalue.Model.copy_offsetmap ~with_alarms right_loc old_state with + | Some v -> v + | None -> raise Lmap.Cannot_copy ( invalid copy paste ) + in + let offsetmap = + Cvalue.V_Offsetmap.over_intersection + offsetmap_relations + offsetmap_memory + in + if not (Cvalue.V_Offsetmap.is_empty offsetmap) + then begin + CilE.set_syntactic_context (CilE.SyMem lv); + let copy_paste_succeeded = + Cvalue.Model.paste_offsetmap with_alarms + offsetmap left_loc.loc Int.zero size true reduced_state + in + ( Shall we warn about imprecise contents just copied? ) + let module L = struct exception Got_imprecise end in + (try + Cvalue.V_Offsetmap.iter_contents + (fun v -> + match Cvalue.V_Or_Uninitialized.get_v v with + | Location_Bytes.Map _ -> () + | _ -> raise L.Got_imprecise) + offsetmap + size + with L.Got_imprecise -> + warn_right_exp_imprecision ()); + copy_paste_succeeded + end + else raise Lmap.Cannot_copy + | _ -> raise Lmap.Cannot_copy + end + in + let new_main_memory_state = + try + if is_bitfield then default() + else + ( An lval assignement might be hidden by a dummy cast ) + let lv = find_lv ~with_alarms old_state exp in + default_lval lv + with Cannot_find_lv | Lmap.Cannot_copy + ( from Cvalue.Model.paste_offsetmap + or directly default_lval ) -> + default () + in + new_main_memory_state + + + let do_assign ~with_alarms old_state lv exp = + if true then do_assign ~with_alarms old_state lv exp + else + let vars = + get_influential_vars ~with_alarms:CilE.warn_none_mode old_state exp + in + let rec try_sub vars = + match vars with + | [] | [ _ ] -> do_assign ~with_alarms old_state lv exp + | v :: tail -> + try + if not (List.exists (fun x -> Locations.loc_equal v x) tail) + then raise Too_linear; + let value = + Cvalue.Model.find + ~conflate_bottom:true + ~with_alarms:CilE.warn_none_mode + old_state + v + in + + if Location_Bytes.is_included value Location_Bytes.top_float + then raise Too_linear; + + ignore (Cvalue.V.splitting_cardinal_less_than + ~split_non_enumerable:42 value 142); +( Value_parameters.debug + "subdiv assignment: candidate %a value %a@." + Locations.pretty v + Cvalue.V.pretty value; ) + let treat_subdiv subvalue acc = + let sub_oldstate = + ( FIXME: should be relation-aware primitive ) + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + old_state + v + subvalue + in + let sub_newstate = + do_assign ~with_alarms sub_oldstate lv exp + in + Cvalue.Model.join acc sub_newstate + in + Location_Bytes.fold_enum + ~split_non_enumerable:42 + treat_subdiv + value + Cvalue.Model.bottom + with + | Not_less_than | Too_linear -> try_sub tail + | Location_Bytes.Error_Top -> assert false; + in + try_sub vars + + let empty_interpretation_result = + None, Cvalue.Model.bottom, Location_Bits.Top_Param.bottom + + let assign_return_to_lv ~with_alarms funcexp lv return new_state = + let loc = lval_to_loc ~with_alarms new_state lv in + let rtype = getReturnType (typeOf funcexp) in + let lvtyp = typeOfLval lv in + let is_bitfield = is_bitfield lv ~sizebf:loc.size ~sizelv:(sizeof lvtyp) () in + let default () = + let value_with_init = + V_Offsetmap.find_ival + ~conflate_bottom:false + ~validity:Base.All + ~with_alarms:CilE.warn_none_mode + Ival.zero + return + (Int.of_int (bitsSizeOf rtype)) + in + let flags = V_Or_Uninitialized.get_flags value_with_init in + let init = V_Or_Uninitialized.is_initialized flags in + let no_esc = V_Or_Uninitialized.is_noesc flags in + let value = V_Or_Uninitialized.get_v value_with_init in + if not init then CilE.warn_uninitialized with_alarms; + if not no_esc then CilE.warn_escapingaddr with_alarms; + if Cvalue.V.is_bottom value && not (init && no_esc) + then + Value_parameters.result ~current:true + "Function call returned an unspecified value. \ + This path is assumed to be dead."; + let exact = valid_cardinal_zero_or_one ~for_writing:true loc in + let evaled_exp = + ( fix http://bts.frama-c.com/view.php?id=798 ) + do_cast ~with_alarms:CilE.warn_none_mode rtype value in + let evaled_exp = + if is_bitfield + then cast_lval_bitfield lv (Int_Base.project loc.size) evaled_exp + else do_cast ~with_alarms:CilE.warn_none_mode lvtyp evaled_exp + in + remember_bases_with_locals loc evaled_exp; + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact + new_state + loc + evaled_exp + in + if is_bitfield || (need_cast lvtyp rtype) + then default () + else + (try + let result = + Cvalue.Model.paste_offsetmap with_alarms + return + loc.loc + Int.zero + (Int_Base.project loc.size) + true + new_state + in + let evaled_exp= + Cvalue.V_Or_Uninitialized.get_v + (V_Offsetmap.find_ival + ~conflate_bottom:false + ~validity:Base.All + ~with_alarms:CilE.warn_none_mode + Ival.zero + return + (Int.of_int (bitsSizeOf rtype)) + ) + in + remember_bases_with_locals loc evaled_exp; + result + with Lmap.Cannot_copy -> default ()) + + let interp_call stmt lval_to_assign funcexp argl d_value = + let call_site_loc = CurrentLoc.get () in + let with_alarms = warn_all_quiet_mode () in + let return_type_funcexp = + match unrollType (typeOf funcexp) with + TFun (t, _, _, _) -> t + | _ -> assert false + in + let bitssizeofreturntypefuncexp = + bitsSizeOf return_type_funcexp + in + let state_after_call state = + try + let functions, _ = resolv_func_vinfo ~with_alarms None state funcexp in + let is_library_function kf = not (Kernel_function.is_definition kf) in + let calling_at_least_one_library_function = + Kernel_function.Hptset.exists is_library_function functions + in + let calling_only_library_functions = + calling_at_least_one_library_function && + (Kernel_function.Hptset.for_all is_library_function functions) + in + let compute_actual = compute_actual ~with_alarms + (calling_at_least_one_library_function, + calling_only_library_functions) + in + let actuals = List.map (compute_actual state) argl in + let treat_one_call f (acc_rt,acc_res,acc_clobbered_set as acc) = + try + let return_type = Kernel_function.get_return_type f in + if bitsSizeOf return_type <> bitssizeofreturntypefuncexp + then raise Wrong_function_type; + + let return, result, clobbered_set = + !compute_call_ref f ~call_kinstr:(Kstmt stmt) state actuals + in + let caller = current_kf (), stmt in + Kf_state.add_caller f ~caller; + CurrentLoc.set call_site_loc; + (match acc_rt,return with + | None,_ -> return + | Some _, None -> acc_rt + | Some acc_rt, Some return -> + Some (snd (V_Offsetmap.join acc_rt return))), + Cvalue.Model.join acc_res result, + Location_Bits.Top_Param.join acc_clobbered_set clobbered_set + with Wrong_function_type -> + warning_once_current + "Pointed function type must match function pointer type when dereferenced: assert(Ook)"; + CilE.stop_if_stop_at_first_alarm_mode (); + acc + in + let return,new_state,clobbered_set = + Kernel_function.Hptset.fold treat_one_call + functions + empty_interpretation_result + in + bases_containing_locals := + Location_Bits.Top_Param.join !bases_containing_locals clobbered_set; + match lval_to_assign with + | None -> new_state + | Some lv -> + match return with + | Some return -> + assign_return_to_lv ~with_alarms funcexp lv return new_state + | None -> + if Cvalue.Model.is_reachable new_state + then + warning_once_current + "In function %t: called function returns void but \ + returned value is assigned; ignoring assignment" + pretty_current_cfunction_name; + new_state + with + | Got_bottom -> + CurrentLoc.set call_site_loc; + Cvalue.Model.bottom + | Leaf -> + CurrentLoc.set call_site_loc; + (match lval_to_assign with + | None -> state + | Some lv -> + let evaled_exp = V.top_leaf_origin () in + do_assign_abstract_value ~with_alarms state lv evaled_exp) + in + State_set.fold + (fun acc state -> State_set.add (state_after_call state) acc) + State_set.empty + d_value + + let doInstr stmt (i: instr) (d: t) = + !Db.progress (); + CilE.start_stmt (Kstmt stmt); + let d_states = d.value in + let unreachable = State_set.is_empty d_states in + let result = + if unreachable then + Dataflow.Done d + else begin + let apply_each_state f = + let modified_states = + State_set.fold + (fun acc state_value -> State_set.add (f state_value) acc) + State_set.empty + d_states + in + Dataflow.Done { counter_unroll = 0; value = modified_states } + in + ( update current statement ) + match i with + | Set (lv,exp,_loc) -> + apply_each_state + (fun state_value -> + do_assign + ~with_alarms:(warn_all_quiet_mode ()) + state_value + lv + exp) + | Call (lval_to_assign, + {enode = Lval (Var {vname=("__builtin_va_start"|"__builtin_va_arg"|"__builtin_va_end" as _builtin_name) },NoOffset)}, + [{enode = Lval lv}],_loc) -> +( Format.printf "builtin: %s@." _builtin_name; ) + apply_each_state + (fun state -> + let state = + do_assign_abstract_value + ~with_alarms:(warn_all_quiet_mode ()) + state + lv + Cvalue.V.top_int + in + ( match lval_to_assign with + None -> state + | Some lval_assign -> + do_assign_abstract_value + ~with_alarms:(warn_all_quiet_mode ()) + state + lval_assign + Cvalue.V.top_int)) + | Call (lval_to_assign,funcexp,argl,_loc) -> + Dataflow.Done + { counter_unroll = 0; + value = interp_call stmt lval_to_assign funcexp argl d_states} + | Asm _ -> + warning_once_current + "assuming assembly code has no effects in function %t" + pretty_current_cfunction_name; + Dataflow.Default + | Skip _ -> + Dataflow.Default + | Code_annot (_,_) -> ( processed in dostmt from Db ) + Dataflow.Default + end + in + CilE.end_stmt (); + result + + ( Reduce the given states according to the given code annotations. + If [record] is true, update the proof state of the code annotation. + DO NOT PASS record=false unless you known what your are doing ) + let interp_annot state stmt ca record = + let aux text behav p = + let in_behavior = + match behav with + | [] -> True + | behavs -> + let ab = AnalysisParam.active_behaviors in + let all_active = Extlib.filter_map' + (ActiveBehaviors.behavior_from_name ab) + (ActiveBehaviors.is_active ab) + behavs + in + if all_active = [] then False + else + if List.exists (ActiveBehaviors.only_active ab) all_active + then True + else Unknown + in + if in_behavior = False + then state + else + let result = fold_join_predicate State_set.fold + (fun here -> + let env = env_annot ~pre:!!fused_initial_state ~here in + eval_predicate ~result:None env p) + state + in + let ip = Property.ip_of_code_annot (current_kf()) stmt ca in + let change_status st = + if record then List.iter (fun p -> emit_status p st) ip + in + let message, result = + (match result, in_behavior with + | Unknown, _ | False, Unknown -> + if State_set.is_empty state then begin + change_status Property_status.False_if_reachable; + "invalid (stopping propagation)", State_set.empty + end else begin + change_status Property_status.Dont_know; + "unknown", state + end + | True, _ -> + change_status Property_status.True; + "valid", state + | False, True -> + change_status Property_status.False_if_reachable; + "invalid (stopping propagation)", State_set.empty + | _, False -> assert false) + in + if record then + Value_parameters.result ~once:true ~current:true + "%s got status %s.%t" text message pp_callstack; + if in_behavior = True then + let env = env_annot ~pre:!!fused_initial_state + ~here:(State_set.join result) in + reduce_by_disjunction ~result:None ~env + result + slevel + p + else + result + in + match ca.annot_content with + | AAssert (behav,p) -> aux "Assertion" behav p + | AInvariant (behav, true, p) -> aux "Loop invariant" behav p + | APragma _ + | AInvariant (_, false, _) + | AVariant _ | AAssigns _ + | AStmtSpec _ (TODO) -> state + + let check_non_overlapping state lvs1 lvs2 = + List.iter + (fun lv1 -> + List.iter + (fun lv2 -> + let zone1 = + Locations.valid_enumerate_bits ~for_writing:false + (lval_to_loc ~with_alarms:CilE.warn_none_mode state lv1) + in + let zone2 = + Locations.valid_enumerate_bits ~for_writing:false + (lval_to_loc ~with_alarms:CilE.warn_none_mode state lv2) + in + if Locations.Zone.intersects zone1 zone2 + then begin + CilE.set_syntactic_context + (CilE.SySep + (Cil.mkAddrOf ~loc:(CurrentLoc.get ()) lv1, + Cil.mkAddrOf ~loc:(CurrentLoc.get ()) lv2)); + CilE.warn_separated warn_all_mode + end) + lvs2) + lvs1 + +( TODO: Take advantage of calls information. ) + let check_unspecified_sequence state seq = + let rec check_one_stmt ((stmt1,_,writes1,_,_) as my_stmt) = function + [] -> () + | (stmt2,_,_,_,_)::seq when stmt1 == stmt2 -> check_one_stmt my_stmt seq + | (stmt2,modified2,writes2,reads2,_) :: seq -> + let unauthorized_reads = + ( TODO: try to have a more semantical interpretation of modified ) + List.filter + (fun x -> List.for_all + (fun y -> not (Cil.compareLval x y)) modified2) + writes1 + in + check_non_overlapping state unauthorized_reads reads2; + if stmt1.sid < stmt2.sid then + check_non_overlapping state writes1 writes2; + check_one_stmt my_stmt seq + in + List.iter (fun x -> check_one_stmt x seq) seq + + let doStmt (s: stmt) (d: t) = + let states = d.value in + d.value <- State_set.empty; + let kinstr = Kstmt s in + + if State_set.is_empty states + then + Dataflow.SDefault + else + let annots_before = + Annotations.single_fold_stmt + (fun a acc -> + match a with + | User { annot_content = AStmtSpec _ } + | AI (_,{annot_content = AStmtSpec _ }) -> acc + | AI (_, b) | User b -> b :: acc) + s + [] + in + CilE.start_stmt kinstr; + let states = + List.fold_left + (fun states annot -> interp_annot states s annot true) + states + annots_before + in + CilE.end_stmt (); + let not_already_states = + if obviously_terminates + then states + else Current_table.update_and_tell_if_changed current_table s states + in + if State_set.is_empty not_already_states + then Dataflow.SDefault + else + let is_return = match s.skind with Return _ -> true | _ -> false in + let new_states = + if d.counter_unroll >= slevel || (is_return && obviously_terminates) + then + let curr_wcounter, curr_wstate = + Current_table.find_widening_info current_table s + in + let state = State_set.join states in + let joined = Cvalue.Model.join curr_wstate state in + if obviously_terminates + then begin + Current_table.update_widening_info current_table s 0 joined; + states + end + else + let r = + if AnalysisParam.is_natural_loop s && curr_wcounter = 0 then + let wh_key_set, wh_hints = getWidenHints s in + let widen_hints = + true, wh_key_set( no longer used thanks to 0/1 widening), + wh_hints + in + snd (Cvalue.Model.widen widen_hints curr_wstate joined) + else + joined + in + let new_widening = + if curr_wcounter = 0 + then 1 + else pred curr_wcounter + in + let new_state = State_set.singleton r in + if Cvalue.Model.equal r joined then ( + Current_table.update_widening_info current_table s new_widening r; + new_state) + else begin + ( Try to correct over-widenings ) + CilE.start_stmt kinstr; + let new_states = + ( Do not record the status after interpreting the annotation + here. Possible unproven assertions have already been + recorded when the assertion has been interpreted the first + time higher in this function. ) + List.fold_left + (fun states annot -> interp_annot states s annot false) + new_state + annots_before + in + CilE.end_stmt (); + let new_joined = State_set.join new_states in + Current_table.update_widening_info + current_table s new_widening new_joined; + State_set.singleton new_joined + end + else states + in + let d = { d with value = new_states } + in + ( match s.skind with + | Loop _ -> + if d.counter_unroll >= slevel && + (Value_parameters.ValShowProgress.get()) + then + Value_parameters.result ~level:1 ~once:true ~current:true + "entering loop for the first time" + | UnspecifiedSequence seq -> + if Kernel.UnspecifiedAccess.get () + then begin + CilE.start_stmt kinstr; + State_set.iter + (fun state -> check_unspecified_sequence state seq) states; + CilE.end_stmt () + end + | _ -> ()); + Dataflow.SUse d + + let doEdge s succ d = + let kinstr = Kstmt s in + let states = d.value in + CilE.start_stmt kinstr; + ( We store the state after the execution of [s] for the callback + {Value.Record_Value_After_Callbacks}. This is done here + because we want to see the values of the variables local to the block ) + if (Value_parameters.ResultsAfter.get () || + not (Db.Value.Record_Value_After_Callbacks.is_empty ())) + && (store_state_after_during_dataflow s succ) + then ( + let old = + try Cil_datatype.Stmt.Hashtbl.find states_after s + with Not_found -> Cvalue.Model.bottom + in + let updated = State_set.fold Cvalue.Model.join old states in + Cil_datatype.Stmt.Hashtbl.replace states_after s updated + ); + + let states = + match Kernel_function.blocks_closed_by_edge s succ with + | [] -> states + | closed_blocks -> + let block_top_addresses_of_locals = + block_top_addresses_of_locals closed_blocks + in + State_set.fold + (fun set state -> + let state = + Cvalue.Model.uninitialize_locals closed_blocks state + in + State_set.add (block_top_addresses_of_locals state) set) + State_set.empty + states; + in + CilE.end_stmt (); + { d with value = states } + + let filterStmt _stmt = true + + ( Remove all local variables and formals from table ) + let externalize return kf = + match kf.fundec with + | Declaration _ -> assert false + | Definition (fundec,_loc) -> + assert + (StmtStartData.iter + (fun k v -> + if State_set.is_empty (v.value) + then () + else (Value_parameters.fatal "sid:%d@\n%a@\n" + k.sid + State_set.pretty (v.value))); + true); + let superpos = + Current_table.find_superposition current_table return + in + let init_state = + Current_table.find_superposition + current_table + (Kernel_function.find_first_stmt kf) + in + let superpos = + let result = + match return with + | {skind = Return (Some ({enode = Lval (Var v,_)}),_)} -> + Some v + | _ -> None + in + check_fct_postconditions ~result + kf + ~init_state + ~active_behaviors:AnalysisParam.active_behaviors + ~post_state:superpos + Normal + in + let state = State_set.join_dropping_relations superpos in + + if Value_parameters.ValShowProgress.get() then + Value_parameters.feedback "Recording results for %a" + Kernel_function.pretty kf; + + merge_current ~degenerate:false; + let ret_val = + (match return with + | {skind = Return (Some ({enode = Lval lv}),_)} -> + offsetmap_of_lv ~with_alarms:(warn_all_quiet_mode ()) state lv + | {skind = Return (None,_)} -> None + | _ -> assert false) + in + let state = + Cvalue.Model.clear_state_from_locals fundec state + in + let offsetmap_top_addresses_of_locals, state_top_addresses_of_locals = + top_addresses_of_locals fundec + in + let result = + (match ret_val with + | None -> ret_val + | Some ret_val -> + let locals, r = offsetmap_top_addresses_of_locals ret_val in + let warn = not (Cvalue.V_Offsetmap.equal r ret_val) + in + if warn then warn_locals_escape_result fundec locals; + Some r), + state_top_addresses_of_locals state, + !bases_containing_locals + in + result + + let doGuardOneCond stmt exp t = + if State_set.is_empty (t.value) + then Dataflow.GUnreachable + else begin + CilE.start_stmt (Kstmt stmt); + let with_alarms = warn_all_quiet_mode () in + let new_values = + State_set.fold + (fun acc state -> + let test = + eval_expr + ~with_alarms + state exp + in + CilE.set_syntactic_context + (CilE.SyBinOp (Ne, Cil.zero ~loc:exp.eloc, exp)); + let warn, _, test = + check_comparable Eq V.singleton_zero test + in + + let do_it = + (warn && Value_parameters.UndefinedPointerComparisonPropagateAll.get ()) || + let t1 = unrollType (typeOf exp) in + if isIntegralType t1 || isPointerType t1 + then V.contains_non_zero test + else true ( TODO: a float condition is true iff != 0.0 ) + in + if do_it then + try + State_set.add + (reduce_by_cond ~with_alarms:CilE.warn_none_mode + state {positive = true; exp = exp}) + acc + with Reduce_to_bottom -> acc + else acc) + State_set.empty + t.value + in + let result = + if State_set.is_empty new_values then Dataflow.GUnreachable + else Dataflow.GUse {t with value = new_values} + in + CilE.end_stmt (); + result + + end + + let mask_then = Db.Value.mask_then + let mask_else = Db.Value.mask_else + + let doGuard stmt exp t = + let not_exp = new_exp ~loc:exp.eloc (UnOp(LNot, exp, intType)) in + let th, el as thel = + doGuardOneCond stmt exp t, doGuardOneCond stmt not_exp t + in + let current_condition_status = + try + Cil_datatype.Stmt.Hashtbl.find conditions_table stmt + with Not_found -> 0 + in + let new_status = + ( if (current_condition_status land mask_then) <> 0 + then mask_then + else + match th with + Dataflow.GUse _ | Dataflow.GDefault -> mask_then + | Dataflow.GUnreachable -> 0) lor + ( if (current_condition_status land mask_else) <> 0 + then mask_else + else + match el with + Dataflow.GUse _ | Dataflow.GDefault -> mask_else + | Dataflow.GUnreachable -> 0) + in + if new_status <> 0 + then Cil_datatype.Stmt.Hashtbl.replace conditions_table stmt new_status; + Separate.filter_if stmt thel +end + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/initial_state.ml frama-c-20111001+nitrogen+dfsg/src/value/initial_state.ml --- frama-c-20110201+carbon+dfsg/src/value/initial_state.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/initial_state.ml 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,662 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Creation of the initial state for Value *) + +open Cil_types +open Cil +open Abstract_interp +open Cvalue +open Locations +open Bit_utils +open Value_util + +exception Initialization_failed + +let make_well hidden_base state loc = + let size = Bit_utils.max_bit_size () in + let well = Cvalue.V.inject_top_origin + Origin.Well + (Cvalue.V.Top_Param.O.singleton hidden_base) + in + let well_loc = + Locations.make_loc + (Location_Bits.inject hidden_base Ival.zero) + (Int_Base.inject size) + in + let state_with_well = + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + well_loc + well + in + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state_with_well + loc + well + +let create_hidden_base + validity_from_type ~hidden_var_name ~name_desc pointed_typ = + let hidden_var = + makeGlobalVar ~generated:false ~logic:true hidden_var_name pointed_typ + in + Globals.Vars.add_decl hidden_var; + hidden_var.vdescr <- Some name_desc; + let validity = + if validity_from_type + then begin + match Base.validity_from_type hidden_var with + | Base.Known (a,b) + when not (Value_parameters.AllocatedContextValid.get ()) -> + Base.Unknown (a,b) + | (Base.All | Base.Unknown _ | Base.Known _) as s -> s + | Base.Periodic _ -> assert false + end + else Base.Unknown (Int.zero,Bit_utils.max_bit_address ()) + in + let hidden_base = Base.create_logic hidden_var validity + in + hidden_base + +(** [initialize_var_using_type varinfo state] uses the type of [varinfo] + to create an initial value in [state]. ) +let initialize_var_using_type varinfo state = + CurrentLoc.set varinfo.vdecl; + let initializing_formal = not varinfo.vglob in + let force_initialize = + initializing_formal || + (Cvalue.Model.has_been_initialized + (Base.create_varinfo varinfo) + state) + in + let rec add_offsetmap depth v name_desc name typ offset_orig typ_orig state = + let typ = Cil.unrollType typ in + let loc = loc_of_typoffset v typ_orig offset_orig in + let rec treat_as_const typ = + (hasAttribute "const" (typeAttrs typ)) || + ( match typ with + TArray (typ, _,_,_) -> treat_as_const (Cil.unrollType typ) + | _ -> false) + in + let must_initialize = + force_initialize || (not (treat_as_const typ)) + in + if not must_initialize + ( if we do not have an initializer for this const, we generate + a formal constant ) + then state else + match typ with + | TInt _ | TEnum (_, _)-> + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + loc + Cvalue.V.top_int + | TFloat ((FDouble | FLongDouble as fkind), _) -> + if fkind = FLongDouble + then + Value_parameters.warning + ~once:true + "Warning: unsupported long double treated as double"; + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + loc + Cvalue.V.top_float + | TFloat (FFloat, _) -> + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + loc + Cvalue.V.top_single_precision_float + | TFun _ -> + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + loc + (Cvalue.V.top_leaf_origin ()) + | TPtr (typ, _) as full_typ + when depth <= Value_parameters.AutomaticContextMaxDepth.get () -> + let attr = typeAttr full_typ in + let context_max_width = + Value_parameters.AutomaticContextMaxWidth.get () + in + if not (isVoidType typ) && not (isFunctionType typ) then + let i = + match findAttribute "arraylen" attr with + | [AInt i] -> i + | _ -> context_max_width + in + let pointed_typ = + TArray(typ, + Some (integer ~loc:varinfo.vdecl i), + empty_size_cache (), + []) + in + let hidden_var_name = + Cabs2cil.fresh_global ("S_" ^ name) + in + let name_desc = ""^name_desc in + let hidden_base = + create_hidden_base + true + ~hidden_var_name + ~name_desc + pointed_typ + in + let state = + add_offsetmap + (depth + 1) + hidden_base + name_desc + hidden_var_name + pointed_typ + NoOffset + pointed_typ + state + in + let value = Cvalue.V.inject hidden_base (Ival.zero) + in + let value = + if Value_parameters.AllocatedContextValid.get () + then value + else Cvalue.V.join Cvalue.V.singleton_zero value + in + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + loc + value + else + let hidden_var_name = + Cabs2cil.fresh_global ("S_" ^ name) + in + let name_desc = ""^name_desc in + let hidden_base = + create_hidden_base + false + ~hidden_var_name + ~name_desc + typ + in + make_well hidden_base state loc + + | TArray (typ, len, _, _) -> + begin try + let size = lenOfArray len in + let state = ref state in + let typ = Cil.unrollType typ in + let treat_index (i : int) = + let offset = + addOffset + (Index (integer ~loc:varinfo.vdecl i, NoOffset)) + offset_orig + in + let name = (string_of_int i) ^"_"^ name in + let name_desc = name_desc ^ "[" ^ (string_of_int i) ^ "]" in + let s = + add_offsetmap depth v + name_desc name typ + offset typ_orig !state + in + state := s; + let loc = loc_of_typoffset v typ_orig offset in + let r_offsetmap = + Cvalue.Model.copy_offsetmap + ~with_alarms:CilE.warn_none_mode + loc s + in + match r_offsetmap with + Some r_offsetmap -> r_offsetmap + | None -> assert false + in + let max_precise_size = + Value_parameters.AutomaticContextMaxWidth.get () + in + if size <= max_precise_size + then + for i = 0 to pred size do + ignore (treat_index i) + done + else begin +( Format.printf "ST %a: size=%d max_precise_size=%d offset=%a@." + Base.pretty v + size + max_precise_size + (!d_offset) offset_orig ; ) + let vv = ref None in + for i = 0 to pred max_precise_size do +( Format.printf "IT %d@.%a@." + i + Cvalue.Model.pretty !state; ) + let r = treat_index i in + vv := + Some + ( match !vv with + None -> r + | Some vv -> snd (Cvalue.V_Offsetmap.join r vv)) + done; + ( match !vv with + None -> assert false + | Some vv -> +( Format.printf "EN %a@." + Cvalue.V_Offsetmap.pretty vv; ) + for i = max_precise_size to pred size do + let offset = + addOffset + (Index (integer ~loc:varinfo.vdecl i, NoOffset)) + offset_orig + in + let loc = loc_of_typoffset v typ_orig offset in + let size = + try + Int_Base.project loc.size + with + | Int_Base.Error_Top + | Int_Base.Error_Bottom -> + assert false + in + state := + Cvalue.Model.paste_offsetmap CilE.warn_none_mode + vv loc.loc Int.zero size true !state + done); + end; + !state + with LenOfArray -> + Value_parameters.result ~once:true ~current:true + "could not find a size for array"; + state + end + | TComp ({cstruct=true;} as compinfo, _, _) -> ( Struct ) + let treat_field (next_offset,state) field = + let new_offset = Field (field, NoOffset) in + let offset = + addOffset + new_offset + offset_orig + in + let field_offset,field_width = bitsOffset typ_orig offset in + let state = + if field_offset>next_offset then ( padding bits needs filling) + let loc = make_loc + (Location_Bits.inject v (Ival.of_int next_offset)) + (Int_Base.inject (Int.of_int (field_offset-next_offset))) + in + Cvalue.Model.add_binding_not_initialized state loc + else state + in + field_offset+field_width, + add_offsetmap + depth + v + (name_desc ^ "." ^ field.fname) + (field.fname^"_"^name) + field.ftype + offset + typ_orig + state + in + begin try + let boff,bwidth = bitsOffset typ_orig offset_orig in + let last_offset,state= List.fold_left + treat_field + (boff,state) + compinfo.cfields + in + if last_offset<(boff+bwidth) then ( padding at end of struct) + let loc = make_loc + (Location_Bits.inject v (Ival.of_int last_offset)) + (Int_Base.inject (Int.of_int (boff+bwidth-last_offset))) + in + Cvalue.Model.add_binding_not_initialized state loc + else state + with Cil.SizeOfError _ -> state + end + | TComp ({cstruct=false}, _, _) when + is_fully_arithmetic typ + -> ( Union of arithmetic types ) + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + loc + Cvalue.V.top_int + + | TPtr _ when Value_parameters.AllocatedContextValid.get () -> + ( deep pointers map to NULL in this case ) + Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + state + loc + Cvalue.V.singleton_zero + + | TBuiltin_va_list _ | TComp _ | TVoid _ | TPtr _ -> + ( variable arguments or union with non-arithmetic type + or deep pointers ) + + ( first create a new varid and offsetmap for the + "hidden location" ) + let hidden_var_name = + Cabs2cil.fresh_global ("WELL_"^name) + in + let hidden_var = + makeGlobalVar ~logic:true hidden_var_name charType + in + hidden_var.vdescr <- Some (name_desc^"_WELL"); + let hidden_base = + Base.create_logic + hidden_var + (Base.Known (Int.zero,Bit_utils.max_bit_address ())) + in + make_well hidden_base state loc + | TNamed (_, _) -> assert false + in + add_offsetmap + 0 + (Base.create_varinfo varinfo) + varinfo.vname varinfo.vname varinfo.vtype NoOffset varinfo.vtype state + +let initial_state_only_globals = + let module S = + State_builder.Option_ref + (Cvalue.Model) + (struct + let name = "only_globals" + let dependencies = + [ Ast.self; Kernel.LibEntry.self; Kernel.MainFunction.self ] + let kind = `Internal + end) + in + function () -> + let compute () = + Value_parameters.debug ~level:2 "Computing globals values"; + let state = ref Cvalue.Model.empty_map in + let update_state st' = + if not (Db.Value.is_reachable st') + then raise Initialization_failed + else state := st' + in + let complete_init ~last_bitsoffset ~abs_offset typ _l lval = + ( process the non initialized bits defaulting to 0 ) + begin try + let size_to_add, offset = + bitsSizeOf typ - last_bitsoffset, + Ival.inject_singleton (Int.of_int abs_offset) + in + assert (size_to_add >= 0); + if size_to_add <> 0 then + let loc = + match lval with + | Var vinfo, _ -> + let base = Base.create_varinfo vinfo in + let size_to_add = (Int.of_int size_to_add) in + let offset, size = + match Base.validity base with + Base.Periodic (mn, _mx, p) when Int.ge size_to_add p -> + Ival.inject_singleton mn, p + | _ -> offset, size_to_add + in + let loc = + Location_Bits.inject base offset + in + let loc = make_loc loc (Int_Base.inject size) in +( Format.printf "loc for final zeroes %a@." + Locations.pretty loc; ) + loc + | _ -> + Value_parameters.error ~current:true + "Whacky initializer ? Please report."; + assert false + in + let v = + if hasAttribute "volatile" (typeAttrs typ) + then V.top_int + else V.singleton_zero + in + update_state + (Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + !state + loc + v) + with Cil.SizeOfError _ -> + Value_parameters.result ~once:true ~current:true + "cannot provide a default initializer: size is unknown" + end + in + let rec eval_init lval init = + match init with + | SingleInit exp -> + let loc = + Eval_exprs.lval_to_loc ~with_alarms:CilE.warn_none_mode + Cvalue.Model.top lval + in +( Format.printf "loc:%a state before:%a@." + Locations.pretty loc + Cvalue.Model.pretty !state; ) + let exact = cardinal_zero_or_one loc in + assert + (if exact then true + else begin + Value_parameters.warning ~current:true + "In global initialisation, the location can not be \ +represented. Aborting."; + false + end); + let value = + Eval_exprs.eval_expr ~with_alarms:(warn_all_quiet_mode ()) + !state + exp + in + let v = + if hasAttribute "volatile" (typeAttrs (Cil.typeOfLval lval)) + then V.top_int + else if not (Int_Base.equal + loc.Locations.size + (Int_Base.inject + (Int.of_int ((bitsSizeOf (typeOf exp)))))) + then ( bit-field ) + ( same sequence used for assignment to bit-fields in the code; + refactor ) + Cvalue.V.cast ~with_alarms:CilE.warn_none_mode + ~size:(Int_Base.project loc.Locations.size) + ~signed:(signof_typeof_lval lval) + value + else value + in + update_state + (Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode ~exact + !state loc v); +( Format.printf "state after:%a@." + Cvalue.Model.pretty !state; ) + + | CompoundInit (base_typ, l) -> + if not (hasAttribute "volatile" (typeAttrs base_typ)) + then + let last_bitsoffset = + foldLeftCompound + ~implicit:false + ~doinit: + (fun off init typ (acc:int) -> + let o,w = bitsOffset base_typ off in + ( Format.printf "acc:%d o:%d w:%d@." acc o w; ) + if acc<o + then begin ( uninitialize the padding bits ) + let vi, (base_off,_) = + (match lval with + | Var vinfo, abs_offset -> + vinfo, + (bitsOffset vinfo.vtype abs_offset) + | _ -> + Value_parameters.fatal "Whacky initializer?") + in + let loc_bits = + Location_Bits.inject + (Base.create_varinfo vi) + (Ival.inject_singleton (Int.of_int (base_off+acc))) + in + let loc_size = Int_Base.inject (Int.of_int (o-acc)) in + let loc = make_loc loc_bits loc_size in +( Format.printf "loc:%a@." Locations.pretty loc; ) + update_state + (Cvalue.Model.add_binding_not_initialized + !state + loc) + end + else assert (acc=o); + if hasAttribute "volatile" (typeAttrs typ) then + warning_once_current + "global initialization of volatile value ignored" + else + eval_init (addOffsetLval off lval) init; + o+w) + ~ct:base_typ + ~initl:l + ~acc:0 + in + let base_off,_ = + (match lval with + | Var vinfo, abs_offset -> + bitsOffset vinfo.vtype abs_offset + | _ -> + Value_parameters.fatal "Whacky initializer?") + in + ( Format.printf "last_bitsoffset:%d base_off:%d@\nstate after:%a@." + last_bitsoffset + base_off + Cvalue.Model.pretty !state; ) + complete_init ~last_bitsoffset + ~abs_offset:(base_off+last_bitsoffset) + base_typ + l + lval + else () + in + Globals.Vars.iter_in_file_order + (fun varinfo init -> + if not varinfo.vlogic then begin + CurrentLoc.set varinfo.vdecl; + match init.init with + | None -> ( Default to zero init ) + if varinfo.vstorage = Extern + then + ( Must not assume zero when the storage is extern. *) + update_state (initialize_var_using_type varinfo !state) + else + complete_init ~last_bitsoffset:0 ~abs_offset:0 + varinfo.vtype [] (Var varinfo,NoOffset) + | Some i -> + eval_init (Var varinfo,NoOffset) i + end); + + (** Bind the declared range for NULL to uninitialized ) + let min_valid = Base.min_valid_absolute_address () in + let max_valid = Base.max_valid_absolute_address () in + if Int.le min_valid max_valid + then begin + let loc_bits = + Location_Bits.inject_ival + (Ival.inject_singleton min_valid) + in + let loc_size = + Int_Base.inject + (Int.length min_valid max_valid) + in + if true ( TODO: command line option *) + then + update_state + (Cvalue.Model.add_binding + ~with_alarms:CilE.warn_none_mode + ~exact:true + !state + (make_loc loc_bits loc_size) + Cvalue.V.top_int) + else + update_state + (Cvalue.Model.add_binding_not_initialized + !state + (make_loc loc_bits loc_size)) + end; + let result = !state in + result + in + S.memo + (fun () -> + try compute () + with Initialization_failed -> Cvalue.Model.bottom) + +(** Compute only once the initial values for globals and NULL ) +let initial_state_contextfree_only_globals = + let module S = + State_builder.Option_ref + (Cvalue.Model) + (struct + let name = "contextfree_only_globals" + let dependencies = + [ Ast.self; Kernel.LibEntry.self; Kernel.MainFunction.self ] + let kind = `Internal + end) + in + function () -> + let add_varinfo state varinfo = + CurrentLoc.set varinfo.vdecl; + initialize_var_using_type varinfo state + in + let treat_global state = function + | GVar(vi,_,_) -> add_varinfo state vi + | GVarDecl(_,vi,_) when not (Cil.isFunctionType vi.vtype) -> + add_varinfo state vi + | GType _ | GCompTag _ | GCompTagDecl _ | GEnumTag _ | GEnumTagDecl _ + | GVarDecl _ | GFun _ | GAsm _ | GPragma _ | GText _ | GAnnot _ -> state + in + let compute () = + List.fold_left treat_global (initial_state_only_globals()) + (Ast.get ()).globals + in + S.memo compute + +let () = + Db.Value.initial_state_only_globals := + (fun () -> + if snd(Globals.entry_point ()) then + initial_state_contextfree_only_globals () + else + initial_state_only_globals () + ); + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/initial_state.mli frama-c-20111001+nitrogen+dfsg/src/value/initial_state.mli --- frama-c-20110201+carbon+dfsg/src/value/initial_state.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/initial_state.mli 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,32 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +val initial_state_only_globals: unit -> Cvalue.Model.t +val initial_state_contextfree_only_globals: unit -> Cvalue.Model.t +val initialize_var_using_type: + Cil_types.varinfo -> Cvalue.Model.t -> Cvalue.Model.t + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/kf_state.ml frama-c-20111001+nitrogen+dfsg/src/value/kf_state.ml --- frama-c-20110201+carbon+dfsg/src/value/kf_state.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/kf_state.ml 2011-10-10 08:38:26.000000000 +0000 @@ -41,7 +41,7 @@ let is_called = Is_Called.memo (fun kf -> - try Value.is_accessible (Kstmt (Kernel_function.find_first_stmt kf)) + try Value.is_reachable_stmt (Kernel_function.find_first_stmt kf) with Kernel_function.No_Statement -> false) let mark_as_called kf = diff -Nru frama-c-20110201+carbon+dfsg/src/value/kf_state.mli frama-c-20111001+nitrogen+dfsg/src/value/kf_state.mli --- frama-c-20110201+carbon+dfsg/src/value/kf_state.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/kf_state.mli 2011-10-10 08:38:26.000000000 +0000 @@ -22,10 +22,10 @@ (** Keep information attached to kernel functions. ) -open Db_types +open Cil_types val mark_as_called: kernel_function -> unit -val add_caller: caller:kernel_functionCil_types.stmt -> kernel_function -> unit +val add_caller: caller:kernel_functionstmt -> kernel_function -> unit ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/value/kinstr.ml frama-c-20111001+nitrogen+dfsg/src/value/kinstr.ml --- frama-c-20110201+carbon+dfsg/src/value/kinstr.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/kinstr.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,192 +0,0 @@ -(**************************************************************************) -(* ) -( This file is part of Frama-C. ) -( ) -( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( ) -( you can redistribute it and/or modify it under the terms of the GNU ) -( Lesser General Public License as published by the Free Software ) -( Foundation, version 2.1. ) -( ) -( It 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 Lesser General Public License for more details. ) -( ) -( See the GNU Lesser General Public License version 2.1 ) -( for more details (enclosed in the file licenses/LGPLv2.1). ) -( *) -(**************************************************************************) - -open Cil_types -open Eval -open Db_types -open Locations -open CilE - -(* [TODO Julien 2007/07/04]: - - is it signature really useful? - - should the comments be somewhere in [Db.Value]? ) -module type Kinstr_S = sig - ( Transform an lval into a location. - The boolean argument forces the analysis to be on bit level. - The result boolean is true iff the transformation is exact. ) - - ( Highlevel function : uses the alias analysis - If [deps] is present, accumulates in deps the locations - encountered while analyzing the [lval] ) - val lval_to_loc_with_deps : - skip_base_deps:bool - -> kinstr - -> deps:Locations.Zone.t - -> lval - -> Locations.Zone.t Locations.location - - val lval_to_loc : kinstr -> lval -> Locations.location - - val expr_to_kernel_function : - kinstr - -> deps:Locations.Zone.t option - -> exp - -> Locations.Zone.t * kernel_function list -end - -let lval_to_loc_with_deps_state ~with_alarms state ~deps lv = - let state, deps, r = - Eval.lval_to_loc_with_deps - ~with_alarms - ~deps - ~reduce_valid_index:(Parameters.SafeArrays.get ()) - state - lv - in - state, Zone.out_some_or_bottom deps, r - -let lval_to_loc_with_deps ~with_alarms kinstr ~deps lv = - CilE.start_stmt kinstr; - let state = Db.Value.noassert_get_state kinstr in - let result = - lval_to_loc_with_deps_state ~with_alarms state ~deps lv in - CilE.end_stmt (); - result - -let lval_to_loc_with_deps_state state ~deps lv = - lval_to_loc_with_deps_state ~with_alarms:warn_none_mode state ~deps lv - -let lval_to_loc_kinstr kinstr ~with_alarms lv = - CilE.start_stmt kinstr; - let state = Db.Value.noassert_get_state kinstr in - (* Format.printf "@\ngot state when lval_to_loc:%a@." - Relations_type.Model.pretty state; ) - let r = lval_to_loc ~with_alarms state lv in - CilE.end_stmt (); - r - -let lval_to_zone kinstr ~with_alarms lv = - Locations.valid_enumerate_bits (lval_to_loc_kinstr ~with_alarms kinstr lv) - -let lval_to_zone_state state lv = - Locations.valid_enumerate_bits (lval_to_loc ~with_alarms:warn_none_mode state lv) - -let expr_to_kernel_function_state ~with_alarms state ~deps exp = - try - let deps, r = resolv_func_vinfo ~with_alarms deps state exp in - Zone.out_some_or_bottom deps, r - with Leaf -> Zone.out_some_or_bottom deps, Kernel_function.Hptset.empty - -let expr_to_kernel_function kinstr ~with_alarms ~deps exp = - CilE.start_stmt kinstr; - let state = Db.Value.noassert_get_state kinstr in - ( Format.printf "STATE IS %a@\n" Relations_type.Model.pretty state;) - let r = - expr_to_kernel_function_state ~with_alarms state ~deps exp - in - CilE.end_stmt (); - r - -let expr_to_kernel_function_state = - expr_to_kernel_function_state ~with_alarms:warn_none_mode - -exception Top_input - -let assigns_to_zone_inputs_state state assigns = - try - let treat_one_zone acc (_,ins) = - match ins with - FromAny -> raise Top_input - | From l -> - List.fold_left - (fun acc term -> - let loc_ins = - !Db.Properties.Interp.identified_term_zone_to_loc ~result:None - state - term - in - Zone.join - acc - (Locations.valid_enumerate_bits loc_ins)) - acc - l - in - match assigns with - WritesAny -> Zone.bottom (VP This corresponds to the old code - (cvs rev 1.9) - Not sure this is what we really want, though. - ) - | Writes [] -> Zone.bottom - | Writes l -> List.fold_left treat_one_zone Zone.bottom l - with - Top_input -> Zone.top - | Invalid_argument "not an lvalue" -> - CilE.warn_once "Failed to interpret assigns clause in inputs"; - Zone.top - -let lval_to_offsetmap kinstr lv ~with_alarms = - CilE.start_stmt kinstr; - let state = Db.Value.noassert_get_state kinstr in - let loc = Locations.valid_part - (lval_to_loc ~with_alarms state lv) - in - let offsetmap = - Relations_type.Model.copy_offsetmap ~with_alarms loc state - in - CilE.end_stmt (); - offsetmap - -let lval_to_offsetmap_state state lv = - let with_alarms = CilE.warn_none_mode in - let loc = Locations.valid_part (lval_to_loc ~with_alarms state lv) in - Relations_type.Model.copy_offsetmap ~with_alarms loc state - - -let () = - Db.Value.lval_to_loc_with_deps := - (fun s ~with_alarms ~deps lval -> - let _, deps, r = lval_to_loc_with_deps ~with_alarms s ~deps lval in - deps, r); - Db.Value.lval_to_loc_with_deps_state := - (fun s ~deps lval -> - let _, deps, r = lval_to_loc_with_deps_state s ~deps lval in - deps, r); - Db.Value.expr_to_kernel_function := expr_to_kernel_function; - Db.Value.expr_to_kernel_function_state := expr_to_kernel_function_state; - Db.Value.lval_to_loc := lval_to_loc_kinstr; - Db.Value.lval_to_loc_state := lval_to_loc ~with_alarms:warn_none_mode ; - Db.Value.lval_to_zone_state := lval_to_zone_state; - Db.Value.lval_to_zone := lval_to_zone; - Db.Value.lval_to_offsetmap := lval_to_offsetmap; - Db.Value.lval_to_offsetmap_state := lval_to_offsetmap_state; - Db.Value.assigns_to_zone_inputs_state := assigns_to_zone_inputs_state; - Db.Value.eval_expr := eval_expr; - Db.Value.eval_lval := - (fun ~with_alarms deps state lval -> - let _, deps, r = eval_lval ~conflate_bottom:true ~with_alarms deps state lval in - deps, r) - -( -Local Variables: -compile-command: "make -C ../.." -End: -*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/kinstr.mli frama-c-20111001+nitrogen+dfsg/src/value/kinstr.mli --- frama-c-20110201+carbon+dfsg/src/value/kinstr.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/kinstr.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -(**************************************************************************) -(* ) -( This file is part of Frama-C. ) -( ) -( Copyright (C) 2007-2011 ) -( CEA (Commissariat � l'�nergie atomique et aux �nergies ) -( alternatives) ) -( ) -( you can redistribute it and/or modify it under the terms of the GNU ) -( Lesser General Public License as published by the Free Software ) -( Foundation, version 2.1. ) -( ) -( It 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 Lesser General Public License for more details. ) -( ) -( See the GNU Lesser General Public License version 2.1 ) -( for more details (enclosed in the file licenses/LGPLv2.1). ) -( *) -(************************************************************************) - -( No function is directly exported. ) - -( -Local Variables: -compile-command: "make -C ../.." -End: -*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/library_functions.ml frama-c-20111001+nitrogen+dfsg/src/value/library_functions.ml --- frama-c-20110201+carbon+dfsg/src/value/library_functions.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/library_functions.ml 2011-10-10 08:38:26.000000000 +0000 @@ -24,40 +24,136 @@ open Cil open Locations open Abstract_interp +open Bit_utils module Retres = - Cil_state_builder.Varinfo_hashtbl + Kernel_function.Make_Table (Cil_datatype.Varinfo) - (struct - let name = "retres_variable" - let size = 9 - let dependencies = [Ast.self] - let kind = `Internal - end) + (struct + let name = "retres_variable" + let size = 9 + let dependencies = [Ast.self] + let kind = `Internal + end) let () = State_dependency_graph.Static.add_dependencies ~from:Retres.self [ Db.Value.self ] -let get f_vi = - try - Retres.find f_vi - with Not_found -> - let typ = Cil.getReturnType f_vi.vtype in - let rv = makeVarinfo false false "__retres" typ in - Retres.add f_vi rv; - rv +let get = Retres.memo + (fun kf -> + let vi = Kernel_function.get_vi kf in + let typ = Cil.getReturnType vi.vtype in + makeVarinfo false false "__retres" typ) -let add_retres_to_state f_vi offsetmap state = - let retres_vi = get f_vi in +let add_retres_to_state ~with_alarms kf offsetmap state = + let retres_vi = get kf in let retres_base = Base.create_varinfo retres_vi in let loc = Location_Bits.inject retres_base Ival.zero in let size = - try - Int.of_int (bitsSizeOf retres_vi.vtype) + try Int.of_int (bitsSizeOf retres_vi.vtype) with SizeOfError _ -> - Value_parameters.abort "library function return type size unknown. Please report" + Value_parameters.abort "library function return type size unknown. \ + Please report" in - Some retres_vi, - Relations_type.Model.paste_offsetmap offsetmap loc Int.zero size state + let state = Cvalue.Model.paste_offsetmap + with_alarms offsetmap loc Int.zero size true state + in + retres_vi, state + + +(** Associates [kernel_function] to a fresh base for the address returned by + the [kernel_function]. ) +module Returned_Val = + Kernel_function.Make_Table + (Base) + (struct + let dependencies = [Ast.self] + let size = 7 + let name = "Leaf_Table" + let kind = `Internal + end) + + +let returned_value kf return_type state = + ( Process return of function ) + let return_type = unrollType return_type in + match return_type with + | TComp _ when is_fully_arithmetic return_type -> + Cvalue.V.top_int, state + | TPtr(typ,_) | (TComp _ as typ) -> begin + let new_base = + Returned_Val.memo + (fun kf -> + ( Value_parameters.warning + "Undefined function returning a pointer: %a" + Kernel_function.pretty kf; ) + let new_varinfo = + makeGlobalVar + ~logic:true + (Cabs2cil.fresh_global + ("alloced_return_" ^ Kernel_function.get_name kf)) + typ + in + let new_offsetmap = + Cvalue.V_Offsetmap.sized_zero (memory_size ()) + in + Cvalue.Default_offsetmap.create_initialized_var + new_varinfo + (Base.Known (Int.zero, max_bit_address ())) + new_offsetmap) + kf + in + let initial_value = + if isIntegralType typ + then Cvalue.V.top_int + else if isFloatingType typ + then Cvalue.V.top_float + else + Cvalue.V.inject_top_origin + (Origin.Leaf (LocationSetLattice.currentloc_singleton())) + (Cvalue.V.Top_Param.O.singleton new_base) + (top_leaf_origin ()) + in + let modu = try + if isVoidType typ then Int.one else Int_Base.project (osizeof typ) + with Int_Base.Error_Top -> + assert (Cvalue.V.is_isotropic initial_value); + Int.one + in + let returned_loc = + try + Location_Bytes.inject + new_base + (Ival.filter_ge_int (Some Int.zero) + (Ival.create_all_values + ~signed:true + ~modu + ~size:(sizeofpointer ()))) + with Int_Base.Error_Top -> + Location_Bytes.inject + new_base + Ival.top + in + let state = + Cvalue.Model.create_initial + ~base:new_base + ~v:initial_value ~modu:(Int.mul Int.eight modu) ~state + in + returned_loc, state + end + | TInt _ | TEnum _ -> Cvalue.V.top_int, state + | TFloat _ -> Cvalue.V.top_float, state + | TBuiltin_va_list _ -> + Cvalue.V.top_leaf_origin() + ( Only some builtins may return this type ), + state + | TVoid _ -> Cvalue.V.top ( this value will never be used ), state + | TFun _ | TNamed _ | TArray _ -> assert false + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/library_functions.mli frama-c-20111001+nitrogen+dfsg/src/value/library_functions.mli --- frama-c-20110201+carbon+dfsg/src/value/library_functions.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/library_functions.mli 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,43 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types + +val add_retres_to_state: + with_alarms:CilE.warn_mode -> + kernel_function -> + Cvalue.V_Offsetmap.t -> + Cvalue.Model.t -> + varinfo * Cvalue.Model.t + +val returned_value: + kernel_function -> + Cil_types.typ -> + Cvalue.Model.t -> + Cvalue.V.t * Cvalue.Model.t + + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/locals_scoping.ml frama-c-20111001+nitrogen+dfsg/src/value/locals_scoping.ml --- frama-c-20110201+carbon+dfsg/src/value/locals_scoping.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/locals_scoping.ml 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,74 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Value analysis of statements and functions bodies ) + +open Cil_types +open Cil +open Cil_datatype +open Locations +open Abstract_interp +open Bit_utils +open Cvalue +open Ast_printer +open Value_util +open Eval_exprs +open Eval_logic + +let remember_bases_with_locals bases_containing_locals left_loc evaled_exp = + if Cvalue.V.contains_addresses_of_any_locals evaled_exp then + let clobbered_set = Location_Bits.get_bases left_loc.loc in + bases_containing_locals := + Location_Bits.Top_Param.join clobbered_set !bases_containing_locals + +let warn_locals_escape is_block fundec k locals = + let pretty_base = Base.pretty in + let pretty_block fmt = Pretty_utils.pp_cond is_block fmt "a block of " in + let sv = fundec.svar in + match locals with + Location_Bytes.Top_Param.Top -> + warning_once_current + "locals escaping the scope of %t%a through %a" + pretty_block + !d_var sv + pretty_base k + | Location_Bytes.Top_Param.Set _ -> + warning_once_current + "locals %a escaping the scope of %t%a through %a" + Location_Bytes.Top_Param.pretty locals + pretty_block + !d_var sv + pretty_base k + +let warn_locals_escape_result fundec locals = + let d_var = !d_var in + let sv = fundec.svar in + match locals with + Location_Bytes.Top_Param.Top -> + warning_once_current + "locals escaping the scope of %a through \\result" + d_var sv + | Location_Bytes.Top_Param.Set _ -> + warning_once_current + "locals %a escaping the scope of %a through \\result" + Location_Bytes.Top_Param.pretty locals + d_var sv diff -Nru frama-c-20110201+carbon+dfsg/src/value/mark_noresults.ml frama-c-20111001+nitrogen+dfsg/src/value/mark_noresults.ml --- frama-c-20110201+carbon+dfsg/src/value/mark_noresults.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/mark_noresults.ml 2011-10-10 08:38:26.000000000 +0000 @@ -26,26 +26,29 @@ inherit Cil.nopCilVisitor as super method vstmt s = - Db.Value.update_table (Kstmt s) Relations_type.Model.top; + Db.Value.update_table s Cvalue.Model.top; Cil.DoChildren end let should_memorize_function name = - not (Value_parameters.NoResultsAll.get() - || (Datatype.String.Set.mem - name.svar.vname (Value_parameters.NoResultsFunctions.get ()))) - + not (Value_parameters.NoResultsAll.get() || + (Value_parameters.ObviouslyTerminatesAll.get()) || + let name = name.svar.vname in + let mem = Datatype.String.Set.mem in + mem name (Value_parameters.NoResultsFunctions.get ()) + || mem name (Value_parameters.ObviouslyTerminatesFunctions.get ())) let run () = - let names = Value_parameters.NoResultsFunctions.get () in - if Value_parameters.NoResultsAll.get() || - not (Datatype.String.Set.is_empty names) - then - let visitor = new mark_visitor in - Globals.Functions.iter_on_fundecs + let visitor = new mark_visitor in + Globals.Functions.iter_on_fundecs (fun afundec -> if not (should_memorize_function afundec) - then - ignore (Cil.visitCilFunction (visitor:>Cil.cilVisitor) afundec);) + then + ignore (Cil.visitCilFunction (visitor:>Cil.cilVisitor) afundec)) +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/non_linear.ml frama-c-20111001+nitrogen+dfsg/src/value/non_linear.ml --- frama-c-20110201+carbon+dfsg/src/value/non_linear.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/non_linear.ml 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,152 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types +open Cil +open Locations +module Ki = Cil_datatype.Kinstr + + +module Location_list = Datatype.List (Locations.Location) + +module Non_linear_assignments = + Cil_state_builder.Varinfo_hashtbl + (Cil_datatype.Kinstr.Hashtbl.Make(Location_list)) + (struct + let name = "Non linear assignments" + let size = 37 + let dependencies = [ Ast.self ] + let kind = `Internal + end) + +module Loc_hashtbl = Hashtbl.Make (Location_Bits) + +class do_non_linear_assignments = object(self) + inherit + Visitor.generic_frama_c_visitor (Project.current ()) (Cil.inplace_visit ()) + as super + val mutable current_locs = None + val mutable assigns_table = + (Ki.Hashtbl.create 17 : Location_list.t Ki.Hashtbl.t) + + method result = assigns_table + + method vstmt s = + current_locs <- None; + match s.skind with + | UnspecifiedSequence seq -> + List.iter + (fun (stmt,_,_,_,_) -> + ignore (visitCilStmt (self:>cilVisitor) stmt)) + seq; + SkipChildren (* do not visit the additional lvals ) + | _ -> super#vstmt s + + method vlval lv = + match current_locs with + None -> SkipChildren + | Some current_locs -> + begin match lv with + Mem _e, _ -> DoChildren + | Var v, NoOffset -> + let loc = Locations.loc_of_varinfo v in + ignore (Loc_hashtbl.find current_locs loc.loc); + SkipChildren + | Var _v, (Index _ | Field _) -> DoChildren + end + +( + + try + + let deps,loc = + !Value.lval_to_loc_with_deps + ~with_alarms:CilE.warn_none_mode + ~deps:Zone.bottom + current_stmt lv + in + let bits_loc = valid_enumerate_bits loc in + self#join deps; + self#join bits_loc; + SkipChildren +) + + method vcode_annot _ = SkipChildren + + method visit_addr lv = + begin match lv with + Var v, offset -> + let offset' = visitCilOffset (self :> cilVisitor) offset in + let v' = Cil.get_varinfo self#behavior v in + if offset' == offset && v == v' + then SkipChildren + else ChangeTo (Var v', offset') + | Mem e, offset -> + let e' = visitCilExpr (self :> cilVisitor) e in + let offset' = visitCilOffset (self :> cilVisitor) offset in + if offset' == offset && e == e' + then SkipChildren + else ChangeTo (Mem e', offset') + end; + + method vinst i = + match i with + | Set (lv,exp,_) -> + current_locs <- Some (Loc_hashtbl.create 7); + begin match lv with + Var _, offset -> + ignore (self#voffs offset); + | Mem e, offset -> + ignore (self#vexpr e); + ignore (self#voffs offset); + end; + ignore (self#vexpr exp); + ( TODO: do some stuff with self#current_stmt ) + SkipChildren + | _ -> SkipChildren + + method vexpr exp = + match exp.enode with + | AddrOf _lv | StartOf _lv -> + SkipChildren ( TODO: do better stuff ) + | _ -> DoChildren + +end + +let compute_non_linear_assignments f = + let vis = new do_non_linear_assignments in + ignore (Visitor.visitFramacFunction (vis:>Visitor.frama_c_visitor) f); + vis#result + +let find fundec = + let var = fundec.svar in + try Non_linear_assignments.find var + with Not_found -> + let nl = compute_non_linear_assignments fundec in + Non_linear_assignments.replace var nl; + nl + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/value/non_linear.mli frama-c-20111001+nitrogen+dfsg/src/value/non_linear.mli --- frama-c-20110201+carbon+dfsg/src/value/non_linear.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/non_linear.mli 2011-10-10 08:38:26.000000000 +0000 @@ -0,0 +1,30 @@ +(**************************************************************************) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +val find: + Cil_types.fundec -> Locations.location list Cil_datatype.Kinstr.Hashtbl.t + +(* +Local Variables: +compile-command: "make -C ../.." +End: +) diff -Nru frama-c-20110201+carbon+dfsg/src/value/register_gui.ml frama-c-20111001+nitrogen+dfsg/src/value/register_gui.ml --- frama-c-20110201+carbon+dfsg/src/value/register_gui.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/register_gui.ml 2011-10-10 08:38:26.000000000 +0000 @@ -25,7 +25,6 @@ open CilE open Format open Db -open Db_types open Pretty_source open Gtk_helper @@ -34,15 +33,73 @@ let vi = Kernel_function.get_vi kf in tree_view#select_global vi -let pretty_offsetmap lv fmt offsetmap = + +type lval_or_absolute = LVal of lval | AbsoluteMem + +let pretty_lval_or_absolute fmt = function + | LVal lv -> !Ast_printer.d_lval fmt lv + | AbsoluteMem -> Format.pp_print_string fmt "[MEMORY]" + +let pretty_offsetmap lva fmt offsetmap = begin match offsetmap with | None -> Format.fprintf fmt "<BOTTOM>" | Some off -> + let typ = match lva with + | LVal lv -> Some (typeOfLval lv) + | AbsoluteMem -> None + in Format.fprintf fmt "%a%a" - !Ast_printer.d_lval lv - (Cvalue_type.V_Offsetmap.pretty_typ - (Some (typeOfLval lv))) - off + pretty_lval_or_absolute lva + (Cvalue.V_Offsetmap.pretty_typ typ) off + end + +let lval_or_absolute_to_offsetmap state lva = + match lva with + | LVal lv -> !Db.Value.lval_to_offsetmap_state state lv + | AbsoluteMem -> + try Some (Cvalue.Model.find_base Base.null state) + with Not_found -> None + +let pretty_lval_or_absolute (annot : GText.buffer) ki lva = + begin ( State before ki ) + annot#insert "Before statement:\n"; + let state = Value.get_state ki in + try + let offsetmap = lval_or_absolute_to_offsetmap state lva in + annot#insert (Pretty_utils.sfprintf "%a@\n" + (pretty_offsetmap lva) offsetmap); + with Lmap.Cannot_copy -> + match lva with + | LVal lv -> + let value = !Db.Value.access ki lv in + let inset_utf8 = Unicode.inset_string () in + annot#insert (Pretty_utils.sfprintf "%a %s %a@\n" + !Ast_printer.d_lval lv + inset_utf8 + Db.Value.pretty value) + | AbsoluteMem -> annot#insert "<>" + end; + begin ( State after ki ) + if Value_parameters.ResultsAfter.get () then + match ki with + | Kstmt ({ skind = Instr _} as stmt) -> + let state = + try Value.AfterTable.find stmt + with Not_found -> Cvalue.Model.bottom + in + let offsetmap_after = lval_or_absolute_to_offsetmap state lva in + annot#insert (Pretty_utils.sfprintf "After statement:\n%a\n" + (pretty_offsetmap lva) offsetmap_after); + | Kglobal | Kstmt _ -> () + else + try + (match lva with + | LVal lv -> + let offsetmap_after = !Db.Value.lval_to_offsetmap_after ki lv in + annot#insert (Pretty_utils.sfprintf "At next statement:@\n%a@\n" + (pretty_offsetmap lva) offsetmap_after) + | AbsoluteMem -> ()) + with Not_found -> () end let gui_annot_action (main_ui:Design.main_window_extension_points) txt = @@ -54,254 +111,201 @@ if not (Db.Value.is_computed ()) then main_ui#launcher () - -module After_States = - State_builder.Hashtbl(Cil_datatype.Stmt.Hashtbl)(Relations_type.Model) - (struct - let name = "Register_gui.After_states" - let dependencies = [Db.Value.self] - let kind = `Correctness - let size = 257 - end) - -( We unconditionnally monitor the states after a statement to - correctly display the "After statement" information of the gui ) -let () = - Db.Value.Record_Value_After_Callbacks.extend - (fun (_stack, h) -> - Cil_datatype.Stmt.Hashtbl.iter - (fun stmt state -> - try - let prev = After_States.find stmt in - After_States.replace stmt (Relations_type.Model.join prev state) - with Not_found -> - After_States.add stmt state - ) h - ) - - +let cleant_outputs kf s = + let outs = Db.Outputs.kinstr (Kstmt s) in + let filter = Locations.Zone.filter_base + (Db.accept_base ~with_formals:true ~with_locals:true kf) in + Extlib.opt_map filter outs let rec to_do_on_select (popup_factory:GMenu.menu GMenu.factory) (main_ui:Design.main_window_extension_points) button_nb selected = - let inset_utf8 = Unicode.inset_string () in - let annot = main_ui#annot_window#buffer in if button_nb = 1 then begin if Db.Value.is_computed () then begin - match selected with - | PStmt (_kf,ki) -> begin - ( Find kinstr and kf ) - ( Is it an accessible statement ? ) - if Db.Value.is_accessible (Kstmt ki) then begin - ( Out for this statement ) - let outs = Db.Outputs.kinstr (Kstmt ki) in - let n = ( match outs with - | Some outs -> - Pretty_utils.sfprintf - "Modifies @[<hov>%a@]@\n" Db.Outputs.pretty outs - | _ -> "\n"); - in annot#insert n - end else annot#insert "This code is dead\n"; - end - | PLval (_kf, ki,lv) -> - if not (isFunctionType (typeOfLval lv)) - then begin - (try - let offsetmap = - !Db.Value.lval_to_offsetmap ~with_alarms:CilE.warn_none_mode ki lv - in - annot#insert (Pretty_utils.sfprintf - "Before statement:@\n%a@\n" - (pretty_offsetmap lv ) offsetmap); - with Lmap.Cannot_copy -> - let value = !Db.Value.access ki lv in - annot#insert (Pretty_utils.sfprintf "Before statement:@\n%a %s %a@\n" - !Ast_printer.d_lval lv inset_utf8 Db.Value.pretty value)); - (( Ugly hack: we use this condition to determine - if the after states have been computed ) - if After_States.length () > 0 then - match ki with - | Kstmt ({ skind = Instr _} as stmt) -> - let state = - try After_States.find stmt - with Not_found -> Relations_type.Model.bottom - in - let offsetmap_after = - !Db.Value.lval_to_offsetmap_state state lv in - annot#insert (Pretty_utils.sfprintf - "After statement:\n%a\n" - (pretty_offsetmap lv) - offsetmap_after); - | Kglobal | Kstmt _ -> () - else - try - let offsetmap_after = - !Db.Value.lval_to_offsetmap_after ki lv in - annot#insert "At next statement:\n"; - annot#insert (Pretty_utils.sfprintf "%a\n" - (pretty_offsetmap lv) offsetmap_after); - with Not_found -> () - ); - end - | PTermLval _ -> () ( JS: TODO (?) ) - | PVDecl (_kf,_vi) -> () - | PGlobal _ | PIP _ -> () - end + match selected with + | PStmt (kf,stmt) -> begin + ( Is it an accessible statement ? ) + if Db.Value.is_reachable_stmt stmt then + ( Out for this statement ) + let outs = cleant_outputs kf stmt in + let n = ( match outs with + | Some outs -> + Pretty_utils.sfprintf + "Modifies @[<hov>%a@]@\n" Db.Outputs.pretty outs + | _ -> "\n"); + in annot#insert n + else annot#insert "This code is dead\n"; + end + | PLval (_kf, ki,lv) -> + if not (isFunctionType (typeOfLval lv)) then + pretty_lval_or_absolute annot ki (LVal lv) + | PTermLval _ -> () ( JS: TODO (?) ) + | PVDecl (_kf,_vi) -> () + | PGlobal _ | PIP _ -> () + end end else if button_nb = 3 then begin match selected with | PVDecl (_,vi) -> - begin - try - let kfun = Globals.Functions.get vi in - if Db.Value.is_computed () - then - let callers = !Value.callers kfun in - ( popup a menu to jump to the definitions of the callers ) - let do_menu l = - try - List.iter - (fun (v,call_sites) -> - let v = Kernel_function.get_vi v in - let nb_sites = List.length call_sites in - let label = "Go to caller " ^ - (Pretty_utils.escape_underscores - (Pretty_utils.sfprintf "%a" - Ast_info.pretty_vname v)) - in - let label = - if nb_sites > 1 - then - label ^ " (" ^ (string_of_int nb_sites) ^" call sites)" - else label - in - ignore - (popup_factory#add_item - label - ~callback: - (fun () -> main_ui#file_tree#select_global v))) - l; - with Not_found -> () - in - do_menu callers - else - ignore - (popup_factory#add_item - "Callers ..." - ~callback: - (fun () -> (gui_compute_values main_ui))) + begin + try + let kfun = Globals.Functions.get vi in + if Db.Value.is_computed () + then + let callers = !Value.callers kfun in + ( popup a menu to jump to the definitions of the callers ) + let do_menu l = + try + List.iter + (fun (kf,call_sites) -> + let nb_sites = List.length call_sites in + let label = "Go to caller " ^ + (Pretty_utils.escape_underscores + (Pretty_utils.sfprintf "%a" + Kernel_function.pretty kf)) + in + let label = + if nb_sites > 1 then + label ^ " (" ^ (string_of_int nb_sites) + ^ " call sites)" + else label + in + ignore + (popup_factory#add_item + label + ~callback: + (fun () -> main_ui#select_or_display_global + (Kernel_function.get_global kf)))) + l; + with Not_found -> () + in + do_menu callers + else + ignore + (popup_factory#add_item + "Callers ..." + ~callback: + (fun () -> (gui_compute_values main_ui))) - with Not_found -> - () + with Not_found -> + () end - | PStmt (kf,ki) -> - if Db.Value.is_computed () - then begin + | PStmt (kf,stmt) -> + if Db.Value.is_computed () + then begin let eval_expr () = - let txt = - GToolbox.input_string + let txt = + GToolbox.input_string ~title:"Evaluate" " Enter an ACSL expression to evaluate " - ( the spaces at beginning and end should not be necessary - but are the quickest fix for an aesthetic GTK problem ) - in - match txt with - | None -> () - | Some txt -> try - let exp = - !Db.Properties.Interp.term_to_exp ~result:None - (!Db.Properties.Interp.expr kf ki txt) - in + ( the spaces at beginning and end should not be necessary + but are the quickest fix for an aesthetic GTK problem ) + in + match txt with + | None -> () + | Some txt -> + try + if txt = "[MEM]" then + pretty_lval_or_absolute annot (Kstmt stmt) AbsoluteMem + else + let exp = + !Db.Properties.Interp.term_to_exp ~result:None + (!Db.Properties.Interp.expr kf stmt txt) + in begin match exp.enode with | Lval lv | StartOf lv -> - to_do_on_select popup_factory main_ui 1 (PLval((Some kf),Kstmt ki,lv)) + pretty_lval_or_absolute annot (Kstmt stmt) (LVal lv) | _ -> - let loc = - !Db.Value.access_expr - (Kstmt ki) - exp - in - let txt = - Format.sprintf + let loc = !Db.Value.access_expr (Kstmt stmt) exp in + let txt = + Format.sprintf "Before the selected statement, all the values taken by the expression %s are contained in %s@\n" - (Pretty_utils.sfprintf "%a" !Ast_printer.d_exp exp) - (Pretty_utils.sfprintf "%a" Cvalue_type.V.pretty loc) - in - annot#insert txt + (Pretty_utils.sfprintf "%a" !Ast_printer.d_exp exp) + (Pretty_utils.sfprintf "%a" Cvalue.V.pretty loc) + in + annot#insert txt end - with e -> - main_ui#error "Invalid expression: %s" (Cmdline.protect e) + with + | Logic_interp.Error (_, mess) -> + main_ui#error "Invalid expression: %s" mess + | Parsing.Parse_error -> + main_ui#error "Invalid expression: %s" "Parse error" + | e -> + main_ui#error "Invalid expression: %s" (Cmdline.protect e) in begin - try - ignore - (popup_factory#add_item "_Evaluate expression" - ~callback:eval_expr) - with Not_found -> () + try + ignore + (popup_factory#add_item "_Evaluate expression" + ~callback:eval_expr) + with Not_found -> () end - end - else - ignore - (popup_factory#add_item - "_Evaluate expression ..." - ~callback: - (fun () -> (gui_compute_values main_ui))) + end + else + ignore + (popup_factory#add_item + "_Evaluate expression ..." + ~callback: + (fun () -> (gui_compute_values main_ui))) | PLval (_kf, ki, lv) -> + if Db.Value.is_computed () then let ty = typeOfLval lv in ( Do special actions for functions ) begin - ( popup a menu to jump the definitions of the given varinfos ) - let do_menu l = - match l with - | [] -> () - | _ -> - try - List.iter - (fun v -> - ignore - (popup_factory#add_item - ("Go to definition of " ^ - (Pretty_utils.escape_underscores - (Pretty_utils.sfprintf "%a" - Ast_info.pretty_vname v)) - ^ " (indirect)") - ~callback: - (fun () -> - main_ui#file_tree#select_global v))) - l ; - with Not_found -> () - in - (match lv with - | Var _,NoOffset when isFunctionType ty -> + ( popup a menu to jump the definitions of the given varinfos ) + let do_menu l = + match l with + | [] -> () + | _ -> + List.iter + (fun v -> + try + let kf = Globals.Functions.get v in + let g = Kernel_function.get_global kf in + ignore + (popup_factory#add_item + ("Go to definition of " ^ + (Pretty_utils.escape_underscores + (Pretty_utils.sfprintf "%a" + Cil_datatype.Varinfo.pretty_vname v)) + ^ " (indirect)") + ~callback: + (fun () -> + main_ui#select_or_display_global g)) + with Not_found -> ()) + l; + in + (match lv with + | Var _,NoOffset when isFunctionType ty -> ( simple literal calls are done by [Design]. ) () - | Mem ({ enode = Lval lv}), NoOffset -> + | Mem ({ enode = Lval lv}), NoOffset -> if isFunctionType ty then ( Function pointers ) - begin try - ( get the list of exact bases in the values ) - let value,_exact = - Cvalue_type.V.find_exact_base_without_offset + begin try + ( get the list of exact bases in the values ) + let value,_exact = + Cvalue.V.find_exact_base_without_offset (!Db.Value.access ki lv) - in - let functions = - List.fold_left + in + let functions = + List.fold_left (fun acc -> - (function - | Base.Var (vi,_) -> vi::acc - | _ -> acc)) + (function + | Base.Var (vi,_) -> vi::acc + | _ -> acc)) [] value - in - do_menu functions + in + do_menu functions - with Not_found -> () + with Not_found -> () end | _ -> () ) @@ -322,53 +326,78 @@ let kind = `Internal end) -let used_var var = - try - UsedVarState.find var - with Not_found -> - let return v = UsedVarState.add var v; v in - try - let f = fst (Globals.entry_point ()) in - let inputs = !Db.Inputs.get_external f - and outputs = !Db.Outputs.get_external f in - let b = Base.create_varinfo var in - return (Locations.Zone.mem_base b inputs || - Locations.Zone.mem_base b outputs) - with e -> - Gui_parameters.error ~once:true - "Exception during usability analysis of var %s: %s" - var.vname (Printexc.to_string e); - return true ( No really sane value, so in doubt... ) - - -let reset (main_ui:Design.main_window_extension_points) = - Globals.Functions.iter - (fun kf -> +let no_memoization_enabled () = + Value_parameters.NoResultsAll.get() || + Value_parameters.ObviouslyTerminatesAll.get() || + not (Value_parameters.NoResultsFunctions.is_empty ()) || + not (Value_parameters.ObviouslyTerminatesFunctions.is_empty ()) + + +let used_var = UsedVarState.memo + (fun var -> + no_memoization_enabled () || + try + let f = fst (Globals.entry_point ()) in + let inputs = !Db.Inputs.get_external f in + let outputs = !Db.Outputs.get_external f in + let b = Base.create_varinfo var in + Locations.Zone.mem_base b inputs || Locations.Zone.mem_base b outputs + with e -> + Gui_parameters.error ~once:true + "Exception during usability analysis of var %s: %s" + var.vname (Printexc.to_string e); + true ( No really sane value, so in doubt... ) + ) + + +( Set when the callback is installed ) +let hide_unused = ref (fun () -> false) + +let sync_filetree (filetree:Filetree.t) = + if not (!hide_unused ()) then + (Globals.Functions.iter + (fun kf -> try let vi = Kernel_function.get_vi kf in - main_ui#file_tree#set_global_attribute + filetree#set_global_attribute ~strikethrough:(Value.is_computed () && not (!Value.is_called kf)) vi with Not_found -> ()); - Globals.Vars.iter - (fun vi _ -> - if vi.vlogic = false then - main_ui#file_tree#set_global_attribute - ~strikethrough:(Value.is_computed () && not (used_var vi)) - vi - ); - List.iter - (fun file -> - ( the display name removes the path ) - let name, _globals = Globals.FileIndex.find file in - let globals_state = main_ui#file_tree#get_file_globals name in - main_ui#file_tree#set_file_attribute - ~strikethrough:(Value.is_computed () && - List.for_all snd globals_state) - name + Globals.Vars.iter + (fun vi _ -> + if vi.vlogic = false then + filetree#set_global_attribute + ~strikethrough:(Value.is_computed () && not (used_var vi)) + vi + ); + if not (filetree#flat_mode) then + List.iter + (fun file -> + ( the display name removes the path ) + let name, _globals = Globals.FileIndex.find file in + let globals_state = filetree#get_file_globals name in + filetree#set_file_attribute + ~strikethrough:(Value.is_computed () && + List.for_all snd globals_state) + name + ) + (Globals.FileIndex.get_files ()) ) - (Globals.FileIndex.get_files ()) + else + ( Some lines may have disappeared. We should reset the entire filetree, + but the method reset of design.ml already does this. ) + () + + +let hide_unused_function_or_var vi = + !hide_unused () && Value.is_computed () && + (try + let kf = Globals.Functions.get vi in + not (!Value.is_called kf) + with Not_found -> + not (used_var vi) + ) module DegeneratedHighlighted = State_builder.Option_ref @@ -380,9 +409,19 @@ end) let main (main_ui:Design.main_window_extension_points) = - - ( reset attributes for the list of source files ) - reset main_ui; + ( Hide unused functions and variables. Must be registered only once ) + hide_unused := + main_ui#file_tree#add_global_filter + ~text:"Hide unused according to\nvalue analysis" + ~key:"value_hide_unused" hide_unused_function_or_var; + + main_ui#file_tree#register_reset_extension sync_filetree; + + ( Very first display, we need to do a few things by hand ) + if !hide_unused () then + main_ui#file_tree#reset () + else + sync_filetree main_ui#file_tree; let value_selector menu (main_ui:Design.main_window_extension_points) ~button localizable = @@ -423,7 +462,8 @@ in main_ui#register_source_highlighter highlighter -let degeneration_occurred ki lv = +let degeneration_occurred _ki _lv = +( Db.Value.mark_as_computed (); ignore (GtkMain.Main.init ()); let app = new Design.main_window () in @@ -432,13 +472,13 @@ (Glib.Idle.add ~prio:1000 (fun () -> let localizable = - (match ki,lv with + (match ki,lv with | Kstmt st, Some lv -> - let kf = snd (Kernel_function.find_from_sid st.sid) in + let kf = Kernel_function.find_englobing_kf st in select_kf app#file_tree kf; PLval(Some kf,ki,lv) | Kstmt st, None -> - let kf = snd (Kernel_function.find_from_sid st.sid) in + let kf = Kernel_function.find_englobing_kf st in select_kf app#file_tree kf; PStmt(kf,st) | Kglobal, Some lv -> @@ -449,23 +489,25 @@ (new GMenu.factory (GMenu.menu ())) app 1 - localizable; + localizable; DegeneratedHighlighted.set localizable; app#rehighlight (); app#scroll localizable (match ki with - | Kstmt st -> + | Kstmt st -> let l = (Cil_datatype.Stmt.loc st.skind) in select_locs ~file:l.file ~line:l.line app#source_viewer - | _ -> ()); + | _ -> ()); false(do it once only))); GMain.Main.main (); +) ignore (raise Db.Value.Aborted) let () = Design.register_extension main; - Design.register_reset_extension reset; - Db.Value.degeneration_occurred := degeneration_occurred + Db.Value.degeneration_occurred := degeneration_occurred; +;; + (* Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/value/register_gui.mli frama-c-20111001+nitrogen+dfsg/src/value/register_gui.mli --- frama-c-20110201+carbon+dfsg/src/value/register_gui.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/register_gui.mli 2011-10-10 08:38:26.000000000 +0000 @@ -28,4 +28,3 @@ compile-command: "make -C ../.." End: ) - diff -Nru frama-c-20110201+carbon+dfsg/src/value/register.ml frama-c-20111001+nitrogen+dfsg/src/value/register.ml --- frama-c-20110201+carbon+dfsg/src/value/register.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/register.ml 2011-10-10 08:38:26.000000000 +0000 @@ -20,68 +20,184 @@ ( *) (**************************************************************************) -(* $id: cvalue.ml,v 1.36 2006/03/17 13:54:56 uid527 Exp $ ) -open Abstract_interp +open Cil_types +open Locations +open Eval_exprs -( -(** Initialize the default bound for absolute address to max addressable bit ) -let () = Parameters.max_valid_absolute_address := Utils.memory_size () -) - -let main () = +(** Main function of the value plugin for the kernel ) - ( Memoization of context free functions ) - let mem_functions = Value_parameters.MemFunctions.get () in - if Value_parameters.MemExecAll.get () - || not (Datatype.String.Set.is_empty mem_functions) - then begin - Value_parameters.feedback "====== MEMOIZING FUNCTIONS ======"; - Ast.compute (); - Globals.Functions.iter +let display_results () = + if Db.Value.is_computed () && Value_parameters.verbose_atleast 1 then begin + Value_parameters.result "====== VALUES COMPUTED ======"; + ( Val display and Inout compute/display ) + !Db.Semantic_Callgraph.topologically_iter_on_functions (fun kf -> - let name = Kernel_function.get_name kf in - if Kernel_function.is_definition kf && - (Value_parameters.MemExecAll.get () - || Datatype.String.Set.mem name mem_functions) - then begin - Value_parameters.feedback "== function %a" - Kernel_function.pretty_name kf; - try - !Db.Value.memoize kf - with Db.Value.Aborted -> - Value_parameters.fatal "Cannot memoize %a: Analysis degenerated@." - Kernel_function.pretty_name kf - end) - end; + if Kernel_function.is_definition kf then + begin + Value_parameters.result "%a" Db.Value.display kf ; + end) + end + +let () = Value_parameters.ForceValues.set_output_dependencies [Db.Value.self] +let main () = ( Value computations ) if Value_parameters.ForceValues.get () then begin !Db.Value.compute (); - Value_parameters.result "====== VALUES COMPUTED ======"; - end; + Value_parameters.ForceValues.output display_results; + end + +let () = Db.Main.extend main + - ( Val display and Inout compute/display *) +(** Functions to register in Db.Value ) - let display_val = - Value_parameters.verbose_atleast 1 && Value_parameters.ForceValues.get () +let lval_to_loc_with_deps_state ~with_alarms state ~deps lv = + let _state, deps, r = + lval_to_loc_with_deps + ~with_alarms + ~deps + ~reduce_valid_index:(Kernel.SafeArrays.get ()) + state + lv in + Zone.out_some_or_bottom deps, r - ( Iteration ) +let lval_to_loc_with_deps kinstr ~with_alarms ~deps lv = + CilE.start_stmt kinstr; + let state = Db.Value.noassert_get_state kinstr in + let result = + lval_to_loc_with_deps_state ~with_alarms state ~deps lv in + CilE.end_stmt (); + result + +let lval_to_loc_kinstr kinstr ~with_alarms lv = + CilE.start_stmt kinstr; + let state = Db.Value.noassert_get_state kinstr in + ( Format.printf "@\ngot state when lval_to_loc:%a@." + Cvalue.Model.pretty state; ) + let r = lval_to_loc ~with_alarms state lv in + CilE.end_stmt (); + r + +let lval_to_zone kinstr ~with_alarms lv = + Locations.valid_enumerate_bits + ~for_writing:false + (lval_to_loc_kinstr ~with_alarms kinstr lv) + +let lval_to_zone_state state lv = + Locations.valid_enumerate_bits + ~for_writing:false + (lval_to_loc ~with_alarms:CilE.warn_none_mode state lv) + +let expr_to_kernel_function_state ~with_alarms state ~deps exp = + try + let r, deps = resolv_func_vinfo ~with_alarms deps state exp in + Zone.out_some_or_bottom deps, r + with Leaf -> Zone.out_some_or_bottom deps, Kernel_function.Hptset.empty + +let expr_to_kernel_function kinstr ~with_alarms ~deps exp = + CilE.start_stmt kinstr; + let state = Db.Value.noassert_get_state kinstr in + ( Format.printf "STATE IS %a@\n" Cvalue.Model.pretty state;) + let r = + expr_to_kernel_function_state ~with_alarms state ~deps exp + in + CilE.end_stmt (); + r - if display_val then - begin - !Db.Semantic_Callgraph.topologically_iter_on_functions - (fun kf -> - if Kernel_function.is_definition kf then - begin - Value_parameters.result "%a" Db.Value.display kf ; - end) - end +let expr_to_kernel_function_state = + expr_to_kernel_function_state ~with_alarms:CilE.warn_none_mode + +exception Top_input + +let assigns_to_zone_inputs_state state assigns = + try + let treat_one_zone acc (_,ins) = + match ins with + FromAny -> raise Top_input + | From l -> + List.fold_left + (fun acc { it_content = term } -> + let loc_ins = + !Db.Properties.Interp.loc_to_loc ~result:None state term + in + Zone.join + acc + (Locations.valid_enumerate_bits ~for_writing:false loc_ins)) + acc + l + in + match assigns with + | WritesAny -> Zone.top + | Writes [] -> Zone.bottom + | Writes l -> List.fold_left treat_one_zone Zone.bottom l + with + | Top_input -> Zone.top + | Invalid_argument "not an lvalue" -> + Value_parameters.warning ~current:true ~once:true + "Failed to interpret assigns clause in inputs"; + Zone.top + +let lval_to_offsetmap kinstr lv ~with_alarms = + CilE.start_stmt kinstr; + let state = Db.Value.noassert_get_state kinstr in + let loc = Locations.valid_part ~for_writing:false + (lval_to_loc ~with_alarms state lv) + in + let offsetmap = + Cvalue.Model.copy_offsetmap ~with_alarms loc state + in + CilE.end_stmt (); + offsetmap + +let lval_to_offsetmap_state state lv = + let with_alarms = CilE.warn_none_mode in + let loc = + Locations.valid_part ~for_writing:false + (lval_to_loc ~with_alarms state lv) + in + Cvalue.Model.copy_offsetmap ~with_alarms loc state + + +( If the function is a builtin, or if the user has requested it, use + \assigns and \from clauses, that give an approximation of the result ) +let use_spec_instead_of_definition kf = + not (Kernel_function.is_definition kf) || + (let name = Kernel_function.get_name kf in + Builtins.overridden_by_builtin name || + Datatype.String.Set.mem name (Value_parameters.UsePrototype.get ()) + ) + +let () = + Db.Value.use_spec_instead_of_definition := use_spec_instead_of_definition; + Db.Value.lval_to_loc_with_deps := lval_to_loc_with_deps; + Db.Value.lval_to_loc_with_deps_state := + lval_to_loc_with_deps_state ~with_alarms:CilE.warn_none_mode; + Db.Value.expr_to_kernel_function := expr_to_kernel_function; + Db.Value.expr_to_kernel_function_state := expr_to_kernel_function_state; + Db.Value.lval_to_loc := lval_to_loc_kinstr; + Db.Value.lval_to_loc_state := lval_to_loc ~with_alarms:CilE.warn_none_mode ; + Db.Value.lval_to_zone_state := lval_to_zone_state; + Db.Value.lval_to_zone := lval_to_zone; + Db.Value.lval_to_offsetmap := lval_to_offsetmap; + Db.Value.lval_to_offsetmap_state := lval_to_offsetmap_state; + Db.Value.assigns_to_zone_inputs_state := assigns_to_zone_inputs_state; + Db.Value.eval_expr := eval_expr; + Db.Value.eval_expr_with_state := + (fun ~with_alarms state expr -> + let (s,_,v) = eval_expr_with_deps_state ~with_alarms None state expr in + s,v); + Db.Value.eval_lval := + (fun ~with_alarms deps state lval -> + let _, deps, r = eval_lval ~conflate_bottom:true ~with_alarms deps state lval in + deps, r); + Db.Value.find_lv_plus := find_lv_plus; +;; -let () = Db.Main.extend main ( Local Variables: -compile-command: "LC_ALL=C make -C ../.. -j" +compile-command: "make -C ../.." End: ) diff -Nru frama-c-20110201+carbon+dfsg/src/value/separate.ml frama-c-20111001+nitrogen+dfsg/src/value/separate.ml --- frama-c-20110201+carbon+dfsg/src/value/separate.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/separate.ml 2011-10-10 08:38:26.000000000 +0000 @@ -28,8 +28,8 @@ then begin let sep_case = Value_parameters.SeparateStmtWord.get() in Value_parameters.feedback "Part of a case analysis: %d of 0..%d" - sep_case - sep_of; + sep_case + sep_of; assert (sep_of >= 1); assert (sep_of <= 1073741823); ( should be enough for anyone ) assert (sep_of land (succ sep_of) = 0); ( pred of power of two ) @@ -47,48 +47,46 @@ then thel else let sep = !mask in - if sep <> 0 && + if sep <> 0 && ( Value_parameters.SeparateStmtStart.is_empty() || - (Value_parameters.SeparateStmtStart.exists - (fun s -> stmt.Cil_types.sid = int_of_string s)) ) + (Value_parameters.SeparateStmtStart.exists + (fun s -> stmt.Cil_types.sid = int_of_string s)) ) then begin - mask := sep lsr 1; - let c = - (Value_parameters.SeparateStmtWord.get()) land sep <> 0 - in - Value_parameters.warning ~current:true - "Statement %d: only propagating for condition %B" - stmt.Cil_types.sid - c; - if c - then - th, Dataflow.GUnreachable - else - Dataflow.GUnreachable, el + mask := sep lsr 1; + let c = + (Value_parameters.SeparateStmtWord.get()) land sep <> 0 + in + Value_parameters.warning ~current:true + "Statement %d: only propagating for condition %B" + stmt.Cil_types.sid + c; + if c + then + th, Dataflow.GUnreachable + else + Dataflow.GUnreachable, el end else thel let epilogue () = let sep = !mask in let word1 = Value_parameters.SeparateStmtWord.get() in - let next = + let next = if sep <> 0 then begin - let unimportant = sep lor pred sep in - let important = lnot unimportant in - let c = word1 in - let mn = c land important in - let mx = c lor unimportant in - let next = succ mx in - Value_parameters.feedback "This analysis covers cases %d to %d" mn mx; - next + let unimportant = sep lor pred sep in + let important = lnot unimportant in + let c = word1 in + let mn = c land important in + let mx = c lor unimportant in + let next = succ mx in + Value_parameters.feedback "This analysis covers cases %d to %d" mn mx; + next end else succ word1 in if next <= Value_parameters.SeparateStmtOf.get() then - Value_parameters.feedback "Next case to cover in sequential order: %d" + Value_parameters.feedback "Next case to cover in sequential order: %d" next; - - diff -Nru frama-c-20110201+carbon+dfsg/src/value/value_parameters.ml frama-c-20111001+nitrogen+dfsg/src/value/value_parameters.ml --- frama-c-20110201+carbon+dfsg/src/value/value_parameters.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/value_parameters.ml 2011-10-10 08:38:26.000000000 +0000 @@ -20,6 +20,38 @@ ( *) (**************************************************************************) +(* Dependencies to kernel options ) +let kernel_parameters_correctness = [ + Kernel.MainFunction.parameter; + Kernel.LibEntry.parameter; + Kernel.AbsoluteValidRange.parameter; + Kernel.Overflow.parameter; + Kernel.SafeArrays.parameter; + Kernel.UnspecifiedAccess.parameter; +] + +let kernel_parameters_precision = [ + Kernel.PreciseUnions.parameter; + Kernel.ArrayPrecisionLevel.parameter; +] + +let parameters_correctness = ref [] +let parameters_tuning = ref [] +let add_dep p = + State_dependency_graph.Static.add_codependencies + ~onto:Db.Value.self [State.get p.Parameter.name] +let add_correctness_dep p = + add_dep p; + parameters_correctness := p :: !parameters_correctness +let add_precision_dep p = + add_dep p; + parameters_tuning := p :: !parameters_tuning +let () = + List.iter add_correctness_dep kernel_parameters_correctness; + List.iter add_precision_dep kernel_parameters_precision; +;; + + include Plugin.Register (struct let name = "value analysis" @@ -30,88 +62,71 @@ end) module ForceValues = - Action + WithOutput (struct let option_name = "-val" let help = "compute values" - let kind = `Tuning + let output_by_default = true end) -module MemFunctions = - StringSet - (struct - let option_name = "-mem-exec" - let arg_name = "f" - let help = "do not unroll calls to function f (experimental)" - let kind = `Tuning - end) +let precision_tuning = add_group "Precision vs. time" +let initial_context = add_group "Initial Context" +let performance = add_group "Results memoization vs. time" -module MemExecAll = - False - (struct - let option_name = "-mem-exec-all" - let help = "(experimental)" - let kind = `Tuning - end) -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ MemFunctions.self; - MemExecAll.self; - ] +( -------------------------------------------------------------------------- ) +( --- Performance options --- ) +( -------------------------------------------------------------------------- ) +let () = Plugin.set_group performance module NoResultsFunctions = StringSet (struct let option_name = "-no-results-function" let arg_name = "f" let help = "do not record the values obtained for the statements of function f" - let kind = `Tuning end) +let () = add_dep NoResultsFunctions.parameter +let () = Plugin.set_group performance module NoResultsAll = False (struct let option_name = "-no-results" let help = "do not record values for any of the statements of the program" - let kind = `Tuning end) +let () = add_dep NoResultsAll.parameter -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - NoResultsFunctions.self; - NoResultsAll.self; - ] - +let () = Plugin.set_group performance +module ObviouslyTerminatesFunctions = + StringSet + (struct + let option_name = "-obviously-terminates-function" + let arg_name = "f" + let help = "do not record the values obtained for the statements of function f" + end) +let () = add_dep ObviouslyTerminatesFunctions.parameter -module SignedOverflow = +let () = Plugin.set_group performance +module ObviouslyTerminatesAll = False (struct - let option_name = "-val-signed-overflow-alarms" - let help = - "Emit alarms for overflows in signed arithmetic. Experimental" - let kind = `Correctness + let option_name = "-obviously-terminates" + let help = "undocumented. Among effects of this options are the same effects as -no-results" end) +let () = add_dep ObviouslyTerminatesAll.parameter -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - SignedOverflow.self; - ] - -module IgnoreRecursiveCalls = - False +let () = Plugin.set_group performance +module ResultsAfter = + Bool (struct - let option_name = "-val-ignore-recursive-calls" - let help = - "Pretend function calls that would be recursive do not happen. Causes unsoundness" - let kind = `Correctness + let option_name = "-val-after-results" + let help = "record precisely the values obtained after the evaluation of each statement" + let default = !Config.is_gui end) +let () = add_dep ResultsAfter.parameter +let () = Plugin.set_group performance module MemoryFootprint = Int (struct @@ -119,10 +134,7 @@ let default = 2 let arg_name = "" let help = "tell the analyser to compromise towards speed or towards low memory use. 1 : small memory; 2 : medium (suitable for recent notebooks); 3 : big (suitable for workstations with 3Gb physical memory or more). Defaults to 2" - let kind = `Tuning end) - - let () = MemoryFootprint.add_set_hook (fun _ x -> @@ -132,7 +144,58 @@ ~from:MemoryFootprint.self [ Binary_cache.MemoryFootprint.self; Buckx.MemoryFootprint.self ] -let initial_context = add_group "Initial Context" + +( ------------------------------------------------------------------------- ) +( --- Misc --- ) +( ------------------------------------------------------------------------- ) + +module PropagateTop = + False + (struct + let option_name = "-propagate-top" + let help = "do not stop value analysis even if it is degenerating" + end) +let () = add_correctness_dep PropagateTop.parameter + +module AllRoundingModes = + False + (struct + let option_name = "-all-rounding-modes" + let help = "Take more target FPU and compiler behaviors into account" + let kind = `Correctness + end) +let () = add_correctness_dep AllRoundingModes.parameter + +module UndefinedPointerComparisonPropagateAll = + False + (struct + let option_name = "-undefined-pointer-comparison-propagate-all" + let help = "if the target program appears to contain undefined pointer comparisons, propagate both outcomes {0; 1} in addition to the emission of an alarm" + end) +let () = add_correctness_dep UndefinedPointerComparisonPropagateAll.parameter + +module SignedOverflow = + False + (struct + let option_name = "-val-signed-overflow-alarms" + let help = + "Emit alarms for overflows in signed arithmetic. Experimental" + end) +let () = add_correctness_dep SignedOverflow.parameter + +module IgnoreRecursiveCalls = + False + (struct + let option_name = "-val-ignore-recursive-calls" + let help = + "Pretend function calls that would be recursive do not happen. Causes unsoundness" + end) +let () = add_correctness_dep IgnoreRecursiveCalls.parameter + + +( ------------------------------------------------------------------------- ) +( --- Initial context --- ) +( ------------------------------------------------------------------------- ) let () = Plugin.set_group initial_context module AutomaticContextMaxDepth = @@ -142,8 +205,8 @@ let default = 2 let arg_name = "n" let help = "use <n> as the depth of the default context for value analysis. (defaults to 2)" - let kind = `Correctness end) +let () = add_correctness_dep AutomaticContextMaxDepth.parameter let () = Plugin.set_group initial_context module AutomaticContextMaxWidth = @@ -153,17 +216,9 @@ let default = 2 let arg_name = "n" let help = "use <n> as the width of the default context for value analysis. (defaults to 2)" - let kind = `Correctness end) let () = AutomaticContextMaxWidth.set_range ~min:1 ~max:max_int - -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - AutomaticContextMaxWidth.self; - AutomaticContextMaxDepth.self; - ] +let () = add_correctness_dep AutomaticContextMaxWidth.parameter let () = Plugin.set_group initial_context module SeparateStmtStart = @@ -172,8 +227,8 @@ let option_name = "-separate-stmts" let arg_name = "n1,..,nk" let help = "Undocumented" - let kind = `Correctness end) +let () = add_correctness_dep SeparateStmtStart.parameter let () = Plugin.set_group initial_context module SeparateStmtWord = @@ -183,9 +238,9 @@ let default = 0 let arg_name = "n" let help = "Undocumented" - let kind = `Correctness end) let () = SeparateStmtWord.set_range ~min:0 ~max:1073741823 +let () = add_correctness_dep SeparateStmtWord.parameter let () = Plugin.set_group initial_context module SeparateStmtOf = @@ -195,36 +250,9 @@ let default = 0 let arg_name = "n" let help = "Undocumented" - let kind = `Correctness end) let () = SeparateStmtOf.set_range ~min:0 ~max:1073741823 - - -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - SeparateStmtStart.self; - SeparateStmtWord.self; - SeparateStmtOf.self; - ] - - -let () = Plugin.set_group initial_context -module AllRoundingModes = - False - (struct - let option_name = "-all-rounding-modes" - let help = "Take more target FPU and compiler behaviors into account" - let kind = `Correctness - end) - -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - AllRoundingModes.self; - ] +let () = add_correctness_dep SeparateStmtOf.parameter let () = Plugin.set_group initial_context module AllocatedContextValid = @@ -232,40 +260,13 @@ (struct let option_name = "-context-valid-pointers" let help = "only allocate valid pointers until context-depth, and then use NULL (defaults to false)" - let kind = `Correctness end) -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - AllocatedContextValid.self; - ] +let () = add_correctness_dep AllocatedContextValid.parameter -let () = Plugin.set_group initial_context -module UndefinedPointerComparisonPropagateAll = - False - (struct - let option_name = "-undefined-pointer-comparison-propagate-all" - let help = "if the target program appears to contain undefined pointer comparisons, propagate both outcomes {0; 1;} in addition to the emission of an alarm" - let kind = `Correctness - end) -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - UndefinedPointerComparisonPropagateAll.self; - ] -let precision_tuning = add_group "Precision tuning" - -let () = Plugin.set_group precision_tuning -module PropagateTop = - False - (struct - let option_name = "-propagate-top" - let help = "do not stop value analysis even if it is degenerating" - let kind = `Tuning - end) +( ------------------------------------------------------------------------- ) +( --- Tuning --- ) +( ------------------------------------------------------------------------- ) let () = Plugin.set_group precision_tuning module WideningLevel = @@ -275,20 +276,9 @@ let option_name = "-wlevel" let arg_name = "n" let help = - "do <n> loop iterations before widening (defaults to 3)" - let kind = `Tuning - end) - -let () = Plugin.set_group precision_tuning -module ArrayPrecisionLevel = - Int - (struct - let default = 200 - let option_name = "-plevel" - let arg_name = "n" - let help = "use <n> as the precision level for arrays accesses. Array accesses are precise as long as the interval for the index contains less than n values. (defaults to 200)" - let kind = `Tuning + "do <n> loop iterations before widening (defaults to 3)" end) +let () = add_precision_dep WideningLevel.parameter let () = Plugin.set_group precision_tuning module SemanticUnrollingLevel = @@ -297,9 +287,18 @@ let option_name = "-slevel" let arg_name = "n" let help = - "use <n> as number of path to explore in parallel (defaults to 0)" - let kind = `Tuning + "use <n> as number of path to explore in parallel (defaults to 0)" end) +let () = add_precision_dep SemanticUnrollingLevel.parameter + +let split_option = + let rx = Str.regexp_string ":" in + fun s -> + try + match Str.split rx s with + | [ f ; n ] -> (f, n) + | _ -> failwith "" + with _ -> failwith "split_option" let () = Plugin.set_group precision_tuning module SlevelFunction = @@ -308,22 +307,37 @@ let option_name = "-slevel-function" let arg_name = "f:n" let help = "override slevel with <n> when analyzing <f>" - let kind = `Tuning end) (struct include Datatype.Int - let rx = Str.regexp_string ":" + let parse s = - try - match Str.split rx s with - [ f ; n ] -> - let n = int_of_string n in - f, n - | _ -> failwith "" - with + try + let f, n = split_option s in + let n = int_of_string n in + f, n + with | Failure _ -> abort "Could not parse option \"-slevel-function %s\"" s let no_binding _ = SemanticUnrollingLevel.get () end) +let () = add_precision_dep SlevelFunction.parameter + +let () = Plugin.set_group precision_tuning +module BuiltinsOverrides = + StringHashtbl + (struct + let option_name = "-val-builtin" + let arg_name = "f:ffc" + let help = "when analyzing function <f>, try to use Frama-C builtin <ffc> instead. Fall back to <f> if <ffc> cannot handle its arguments (experimental)." + end) + (struct + include Datatype.String + let parse s = + try split_option s + with Failure _ -> abort "Could not parse option \"-val-builtin %s\"" s + let no_binding _ = raise Not_found + end) +let () = add_precision_dep BuiltinsOverrides.parameter let () = Plugin.set_group precision_tuning module Subdivide_float_in_expr = @@ -332,21 +346,54 @@ let option_name = "-subdivide-float-var" let arg_name = "n" let help = - "use <n> as number of subdivisions allowed for float variables in expressions (experimental, defaults to 0)" - let kind = `Tuning + "use <n> as number of subdivisions allowed for float variables in expressions (experimental, defaults to 0)" end) +let () = add_precision_dep Subdivide_float_in_expr.parameter + +let () = Plugin.set_group precision_tuning +module UsePrototype = + StringSet + (struct + let option_name = "-val-use-spec" + let arg_name = "f1,..,fn" + let help = "undocumented" + end) +let () = add_precision_dep UsePrototype.parameter + +let () = Plugin.set_group precision_tuning +module RmAssert = + False + (struct + let option_name = "-remove-redundant-alarms" + let help = "after the analysis, try to remove redundant alarms, so that the user needs inspect fewer of them" + end) +let () = add_precision_dep RmAssert.parameter + + +( ------------------------------------------------------------------------- ) +( --- Messages --- ) +( ------------------------------------------------------------------------- ) + +let () = Plugin.set_group messages +module ValShowProgress = + True + (struct + let option_name = "-val-show-progress" + let help = "Show progression messages during value analysis" + end) + +let () = Plugin.set_group messages +module PrintCallstacks = + False + (struct + let option_name = "-val-print-callstacks" + let help = "When printing a message, also show the current analysis context." + end) + + +let parameters_correctness = !parameters_correctness +let parameters_tuning = !parameters_tuning -let () = - State_dependency_graph.Static.add_codependencies - ~onto:Db.Value.self - [ - PropagateTop.self; - WideningLevel.self; - ArrayPrecisionLevel.self; - SemanticUnrollingLevel.self; - SlevelFunction.self; - Subdivide_float_in_expr.self; - ] ( Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/value/value_parameters.mli frama-c-20111001+nitrogen+dfsg/src/value/value_parameters.mli --- frama-c-20110201+carbon+dfsg/src/value/value_parameters.mli 2011-02-07 13:59:39.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/value_parameters.mli 2011-10-10 08:38:26.000000000 +0000 @@ -22,43 +22,54 @@ include Plugin.S -module ForceValues: Plugin.BOOL +module ForceValues: Plugin.WithOutput -module PropagateTop: Plugin.BOOL +module PropagateTop: Plugin.Bool -module AutomaticContextMaxDepth: Plugin.INT -module AutomaticContextMaxWidth: Plugin.INT +module AutomaticContextMaxDepth: Plugin.Int +module AutomaticContextMaxWidth: Plugin.Int -module SeparateStmtStart: Plugin.STRING_SET -module SeparateStmtWord: Plugin.INT -module SeparateStmtOf: Plugin.INT +module SeparateStmtStart: Plugin.String_set +module SeparateStmtWord: Plugin.Int +module SeparateStmtOf: Plugin.Int -module AllRoundingModes: Plugin.BOOL +module AllRoundingModes: Plugin.Bool -module MemFunctions: Plugin.STRING_SET -module MemExecAll: Plugin.BOOL +module NoResultsFunctions: Plugin.String_set +module NoResultsAll: Plugin.Bool -module NoResultsFunctions: Plugin.STRING_SET -module NoResultsAll: Plugin.BOOL +module ObviouslyTerminatesAll: Plugin.Bool +module ObviouslyTerminatesFunctions: Plugin.String_set -module SignedOverflow: Plugin.BOOL +module ResultsAfter: Plugin.Bool -module IgnoreRecursiveCalls: Plugin.BOOL +module SignedOverflow: Plugin.Bool -module MemoryFootprint: Plugin.INT +module IgnoreRecursiveCalls: Plugin.Bool +module ValShowProgress: Plugin.Bool -module SemanticUnrollingLevel: Plugin.INT +module MemoryFootprint: Plugin.Int -module AllocatedContextValid: Plugin.BOOL +module SemanticUnrollingLevel: Plugin.Int -module UndefinedPointerComparisonPropagateAll: Plugin.BOOL +module AllocatedContextValid: Plugin.Bool -module ArrayPrecisionLevel: Plugin.INT +module UndefinedPointerComparisonPropagateAll: Plugin.Bool -module WideningLevel: Plugin.INT -module SlevelFunction: Plugin.STRING_HASHTBL with type value = int +module WideningLevel: Plugin.Int +module SlevelFunction: Plugin.String_hashtbl with type value = int -module Subdivide_float_in_expr: Plugin.INT +module UsePrototype: Plugin.String_set + +module RmAssert: Plugin.Bool + +module Subdivide_float_in_expr: Plugin.Int +module BuiltinsOverrides: Plugin.String_hashtbl with type value = string + +module PrintCallstacks: Plugin.Bool + +val parameters_correctness: Parameter.t list +val parameters_tuning: Parameter.t list (* Local Variables: diff -Nru frama-c-20110201+carbon+dfsg/src/value/value_util.ml frama-c-20111001+nitrogen+dfsg/src/value/value_util.ml --- frama-c-20110201+carbon+dfsg/src/value/value_util.ml 2011-02-07 13:53:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/value/value_util.ml 2011-10-10 08:38:26.000000000 +0000 @@ -20,13 +20,9 @@ (* *) (************************************************************************) -open Db_types open Cil_types -let get_rounding_mode () = - if Value_parameters.AllRoundingModes.get () - then Ival.Float_abstract.Any - else Ival.Float_abstract.Nearest_Even +( Callstacks related types and functions ) type called_function = { called_kf : kernel_function; @@ -34,34 +30,8 @@ called_merge_current : degenerate:bool -> unit} let call_stack : called_function list ref = ref [] - let call_stack_for_callbacks : (kernel_function kinstr) list ref = ref [] - -let do_degenerate lv = - List.iter - (fun {called_merge_current = merge_current } -> - merge_current ~degenerate:true) - !call_stack; - !Db.Value.degeneration_occurred (CilE.current_stmt ()) lv - -let warn_all_quiet_mode () = - if Value_parameters.verbose_atleast 1 then - CilE.warn_all_mode - else - { CilE.warn_all_mode with CilE.imprecision_tracing = CilE.Aignore } - - -let pretty_actuals fmt actuals = - Pretty_utils.pp_flowlist (fun fmt (_,x,_) -> Cvalue_type.V.pretty fmt x) - fmt actuals - -let pretty_call_stack fmt callstack = - Pretty_utils.pp_flowlist ~left:"" ~sep:" <-" ~right:"" - (fun fmt {called_kf = kf} -> Kernel_function.pretty_name fmt kf) - fmt - callstack - let clear_call_stack () = call_stack := []; call_stack_for_callbacks := [] @@ -80,6 +50,94 @@ let call_stack () = !call_stack let for_callbacks_stack () = !call_stack_for_callbacks +let pretty_call_stack fmt callstack = + Pretty_utils.pp_flowlist ~left:"" ~sep:" <- " ~right:"" + (fun fmt {called_kf = kf} -> Kernel_function.pretty fmt kf) + fmt + callstack + +let pretty_callbacks_call_stack fmt callstack = + Format.fprintf fmt "@[<hv>"; + List.iter (fun (kf, ki) -> + Kernel_function.pretty fmt kf; + match ki with + | Kglobal -> () + | Kstmt stmt -> Format.fprintf fmt " :: %a <-@ " + Cil_datatype.Location.pretty (Cil_datatype.Stmt.loc stmt) + ) callstack; + Format.fprintf fmt "@]" + +let pp_callstack fmt = + if Value_parameters.PrintCallstacks.get () then + Format.fprintf fmt "@ stack: %a" + pretty_callbacks_call_stack !call_stack_for_callbacks +;; + +(** Misc *) + +let get_rounding_mode () = + if Value_parameters.AllRoundingModes.get () + then Ival.Float_abstract.Any + else Ival.Float_abstract.Nearest_Even + +let do_degenerate lv = + List.iter + (fun {called_merge_current = merge_current } -> + merge_current ~degenerate:true) + (call_stack ()); + !Db.Value.degeneration_occurred (CilE.current_stmt ()) lv + +(** Assertions emitted during the analysis ) + +let emitter_value = + Emitter.create + "value analysis" + ~correctness:Value_parameters.parameters_correctness + ~tuning:Value_parameters.parameters_tuning + +let emit_status ppt s = + Property_status.emit ~distinct:true emitter_value ~hyps:[] ppt s + +let warn_all_mode = + CilE.warn_all_mode { CilE.warn_emitter = emitter_value; + warn_deps = [Db.Value.self] } + +let warn_all_quiet_mode () = + if Value_parameters.verbose_atleast 1 then + warn_all_mode + else + { warn_all_mode with CilE.imprecision_tracing = CilE.Aignore } + +let get_slevel kf = + let name = Kernel_function.get_name kf in + Value_parameters.SlevelFunction.find name + +let set_loc kinstr = + match kinstr with + | Kglobal -> Cil.CurrentLoc.clear () + | Kstmt s -> Cil.CurrentLoc.set (Cil_datatype.Stmt.loc s) + +module Got_Imprecise_Value = + State_builder.Ref + (Datatype.Bool) + (struct + let name = "Eval.Got_Imprecise_Value" + let dependencies = [ Db.Value.self ] + let kind = `Internal + let default () = false + end) + +let pretty_actuals fmt actuals = + Pretty_utils.pp_flowlist (fun fmt (_,x,_) -> Cvalue.V.pretty fmt x) + fmt actuals + +let pretty_current_cfunction_name fmt = + Kernel_function.pretty fmt (current_kf()) + +let warning_once_current fmt = + Value_parameters.warning ~current:true ~once:true fmt + + ( Local Variables: compile-command: "make -C ../.." diff -Nru frama-c-20110201+carbon+dfsg/src/wp/ACSL.ml frama-c-20111001+nitrogen+dfsg/src/wp/ACSL.ml --- frama-c-20110201+carbon+dfsg/src/wp/ACSL.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/ACSL.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,481 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Custom Registries --- ) +( -------------------------------------------------------------------------- ) + +module type Compiler = +sig + type key + type data + val name : string + val reprs : data list + val compile : key -> data +end + +module Register(K : Datatype.Hashtbl)(C : Compiler with type key = K.key) = +struct + + type value = Data of C.data | Error of exn | Locked + + module D : Datatype.S with type t = value = + Datatype.Make + (struct + include Datatype.Undefined + type t = value + let name = "Wp.Data." ^ C.name + let reprs = Locked :: Error Exit :: List.map (fun x -> Data x) C.reprs + end) + + module H = State_builder.Hashtbl(K)(D) + (struct + let name = "Wp.ACSL." ^ C.name + let dependencies = [Ast.self] + let kind = `Tuning + let size = 231 + end) + + let get_value x = + try H.find x + with Not_found -> + H.replace x Locked ; + let value = try Data(C.compile x) with exn -> Error exn in + H.replace x value ; value + + let obtain x = + match get_value x with + | Locked -> Wp_parameters.fatal "Cyclic compilation (%a)" K.Key.pretty x + | Error exn -> raise exn + | Data y -> y + +end + +( -------------------------------------------------------------------------- ) +( --- ACSL Definitions --- ) +( -------------------------------------------------------------------------- ) + +open Ctypes +open Cil_types +open Cil_datatype + +open LogicId +open LogicTau +open LogicLang +open LogicDef + +let dtau_ctype : (typ -> tau) ref = ref (fun _ -> assert false) +let dhas_ctype : (typ -> term -> pred) ref = ref (fun _ _ -> assert false) +let deq_ctype : (typ -> term -> term -> pred) ref = ref (fun _ _ _ -> assert false) + +( -------------------------------------------------------------------------- ) +( --- Array with Dimension --- ) +( -------------------------------------------------------------------------- ) + +module Tarray = + Datatype.Make_with_collections + (struct + include Datatype.Undefined + type t = typ int option list + let name = "Wp.ACSL.Tarray" + let reprs = [TVoid[],[]] + let pp_hash_dim h = function + | None -> h * 731 + | Some d -> h * 731 + d * 27 + let hash (te,dims) = + List.fold_left pp_hash_dim (Typ.hash te) dims + let equal (t1,d1) (t2,d2) = + Pervasives.(=) d1 d2 && Typ.equal t1 t2 + let compare _ _ = 0 (* incorrect but never used ) + let pp_dim fmt = function + | None -> Format.pp_print_string fmt "[]" + | Some d -> Format.fprintf fmt "[%d]" d + let pretty fmt (te,dims) = + Typ.pretty fmt te ; List.iter (pp_dim fmt) dims + end) + +( Find the head-dimension of an array ) +let tarray_dim = function + | None -> None + | Some aflat -> + try Some(Int64.to_int aflat.arr_size) + with _ -> None + +( t-array extraction ) +let rec tarray_of_typ t ds = + match object_of t with + | C_array info -> tarray_of_arrayinfo info ds + | _ -> t,ds + +and tarray_of_arrayinfo info ds = + let d = tarray_dim info.arr_flat in + tarray_of_typ info.arr_element (d::ds) + +let rec tau_of_tarray tau = function + | [] -> tau + | _::ds -> tau_of_tarray (Array(Integer,tau)) ds + +let tarray_elt fmt te = + match object_of te with + | C_int i -> pp_int fmt i + | C_float f -> pp_float fmt f + | C_comp c -> Format.pp_print_string fmt c.cname + | C_array _ -> Wp_parameters.fatal "incomplete array-dimension" + | C_pointer _ -> Wp_parameters.fatal "pointer array constraint" + +let tarray_name te ds = + Pretty_utils.sfprintf "%a%t" tarray_elt te + (fun fmt -> + List.iter + (function + | None -> Format.fprintf fmt "_arr" + | Some n -> Format.fprintf fmt "_a%d" n + ) ds) + +let in_range i d p = + match d with + | None -> p + | Some n -> + let k = e_var i in + p_goal [ p_icmp Cleq e_zero k ; p_icmp Clt k (e_int n) ] p + +module Darray = + Datatype.Make_with_collections + (struct + include Datatype.Undefined + type t = typ int + let name = "Wp.ACSL.Darray" + let reprs = [TVoid[],0] + let hash (te,dims) = 31(Typ.hash te) + dims + let equal (t1,d1) (t2,d2) = + Pervasives.(=) d1 d2 && Typ.equal t1 t2 + let compare _ _ = 0 ( incorrect but never used ) + let pretty fmt (te,dims) = + Typ.pretty fmt te ; + for i=1 to dims do Format.pp_print_string fmt "[]" done + end) + +let rec tau_of_darray te n = + if n > 0 then Array(Integer, tau_of_darray te (pred n)) else te + +let darray_name te n = Pretty_utils.sfprintf "%a_d%d" tarray_elt te n + +let rec darray_of_arrayinfo info n = + let te = info.arr_element in + match object_of te with + | C_int _ | C_float _ | C_pointer _ | C_comp _ -> te , n + | C_array arr -> darray_of_arrayinfo arr (succ n) + +( -------------------------------------------------------------------------- ) +( --- C-Comp --- ) +( -------------------------------------------------------------------------- ) + +module Fmap = Fieldinfo.Map +module Record = Register(Compinfo.Hashtbl) + (struct + + type key = compinfo + type data = id field Fmap.t + + let name = "Record" + let reprs = [LogicId.dummy,Fmap.empty] + + let compile comp = + let prefix = if comp.cstruct then "S_" else "U_" in + let record_id = LogicId.create (prefix ^ comp.cname) in + let record_fields = ref [] in + let compile_fields = ref Fmap.empty in + List.iter + (fun f -> + let field = { + LogicTau.f_name = LogicId.create ("F_" ^ f.fname) ; + LogicTau.f_type = !dtau_ctype f.ftype ; + LogicTau.f_record = record_id ; + } in + record_fields := field :: !record_fields ; + compile_fields := Fmap.add f field !compile_fields ; + ) comp.cfields ; + let descr = { + t_source = fst (List.hd comp.cfields).floc ; + t_short = (if comp.cstruct then "struct " else "union ") ^ comp.corig_name ; + t_descr = "" ; + } in + LogicDef.declare { + d_name = record_id ; + d_item = RECORD (List.rev !record_fields) ; + d_descr = descr ; + } ; + (record_id , !compile_fields) + + end) + +let record_of comp = fst (Record.obtain comp) +let field_of finfo = Fmap.find finfo (snd (Record.obtain finfo.fcomp)) + +(* -------------------------------------------------------------------------- ) +( --- ADT-Types --- ) +( -------------------------------------------------------------------------- ) + +module ADT = Register(Logic_type_info.Hashtbl) + (struct + type key = logic_type_info + type data = id + let name = "ADT" + let reprs = [LogicId.dummy] + let compile lt = + let tid = LogicId.create ("T_" ^ lt.lt_name) in + LogicDef.declare { + d_name = tid ; + d_item = TYPE (List.length lt.lt_params) ; + d_descr = { + t_source = Lexing.dummy_pos ; + t_short = Printf.sprintf "logic type %s" lt.lt_name ; + t_descr = "" ; + } ; + } ; tid + end) + +( -------------------------------------------------------------------------- ) +( --- Types --- ) +( -------------------------------------------------------------------------- ) + +open Ctypes + +let rec tau_of_ctype t = + tau_of_object (Ctypes.object_of t) + +and tau_of_object = function + | C_int _ -> Integer + | C_float _ -> Real + | C_pointer _ -> Pointer + | C_comp c -> Record (record_of c) + | C_array a -> Array(Integer,tau_of_ctype a.arr_element) + +and tau_of_logic_type = function + | Ctype c -> tau_of_ctype c + | Linteger -> Integer + | Lreal -> Real + | Ltype( d , [] ) when d.lt_name = Utf8_logic.boolean -> Boolean + | Ltype( {lt_name="set"} , [t] ) -> Set (tau_of_logic_type t) + | Ltype( lt , ts) -> ADT( ADT.obtain lt , List.map tau_of_logic_type ts ) + | Lvar _ -> Wp_parameters.not_yet_implemented "logic type variables" + | Larrow _ -> Wp_parameters.not_yet_implemented "type of logic function" + +let () = dtau_ctype := tau_of_ctype + +( -------------------------------------------------------------------------- ) +( --- Is Int --- ) +( -------------------------------------------------------------------------- ) + +let lib_is_int = List.map + (fun i -> i , LogicId.library (Pretty_utils.sfprintf "is_%a" pp_int i)) + Ctypes.c_int_all + +let lib_to_int = List.map + (fun i -> i , LogicId.library (Pretty_utils.sfprintf "to_%a" pp_int i)) + Ctypes.c_int_all + +let is_int i = List.assoc i lib_is_int +let to_int i = List.assoc i lib_to_int + +( -------------------------------------------------------------------------- ) +( --- Is Comp --- ) +( -------------------------------------------------------------------------- ) + +module IsComp = Register(Compinfo.Hashtbl) + (struct + type key = compinfo + type data = id + let name = "IsComp" + let reprs = [LogicId.dummy] + let compile compinfo = + let record = record_of compinfo in + let pid = LogicId.create ("Is_" ^ compinfo.cname) in + let pool = LogicLang.pool () in + let r_var = LogicLang.fresh pool "r" (Record record) in + let r_val = e_var r_var in + let has_ftype f = + !dhas_ctype f.Cil_types.ftype (e_getfield r_val (field_of f)) + in + let condition = p_conj (List.map has_ftype compinfo.cfields) in + LogicDef.declare { + d_name = pid ; + d_item = PREDICATE([r_var],Some condition) ; + d_descr = { + t_source = Lexing.dummy_pos ; + t_short = "subtype " ^ compinfo.corig_name ; + t_descr = "" ; + } ; + } ; pid + end) + +( -------------------------------------------------------------------------- ) +( --- Is Array --- ) +( -------------------------------------------------------------------------- ) + +let rec is_darray pool te dims a = + if dims > 0 then + let i = LogicLang.fresh pool "i" Integer in + let a_i = e_access a (e_var i) in + p_forall i (is_darray pool te (pred dims) a_i) + else + !dhas_ctype te a + +module IsArray = Register(Darray.Hashtbl) + (struct + type key = Darray.t + type data = id + let name = "IsArray" + let reprs = [LogicId.dummy] + let compile (te,dims) = + let tau = tau_of_ctype te in + let tau_dim = tau_of_darray tau dims in + let aid = LogicId.create ("Is_" ^ darray_name te dims) in + let pool = LogicLang.pool () in + let a = LogicLang.fresh pool "a" tau_dim in + let condition = is_darray pool te dims (e_var a) in + LogicDef.declare { + d_name = aid ; + d_item = PREDICATE([a],Some condition) ; + d_descr = { + t_source = Lexing.dummy_pos ; + t_short = "subtype of array" ; + t_descr = "" ; + } ; + } ; aid + end) + +( -------------------------------------------------------------------------- ) +( --- ACSL-Types --- ) +( -------------------------------------------------------------------------- ) + +let rec has_ctype typ term = has_object (object_of typ) term +and has_object obj term = + match obj with + | C_float _ | C_pointer _ -> p_true + | C_int i -> p_call (is_int i) [term] + | C_comp c -> p_call (IsComp.obtain c) [term] + | C_array info -> + let ta = darray_of_arrayinfo info 1 in + match object_of (fst ta) with + | C_float _ | C_pointer _ -> p_true + | C_array _ -> Wp_parameters.fatal "non canonical array-dimension" + | C_int _ | C_comp _ -> + p_call (IsArray.obtain ta) [term] + +let () = dhas_ctype := has_ctype + +( -------------------------------------------------------------------------- ) +( --- Eq-Comp --- ) +( -------------------------------------------------------------------------- ) + +module EqComp = Register(Compinfo.Hashtbl) + (struct + type key = compinfo + type data = id + let reprs = [LogicId.dummy] + let name = "EqComp" + let compile compinfo = + let record = record_of compinfo in + let cid = LogicId.create ("Eq_" ^ compinfo.cname) in + let pool = LogicLang.pool () in + let a = LogicLang.fresh pool "a" (Record record) in + let b = LogicLang.fresh pool "b" (Record record) in + let a_val = e_var a in + let b_val = e_var b in + let eq_field f = + let fd = field_of f in + !deq_ctype f.Cil_types.ftype (e_getfield a_val fd) (e_getfield b_val fd) + in + let condition = p_conj (List.map eq_field compinfo.cfields) in + LogicDef.declare { + d_name = cid ; + d_item = PREDICATE([a;b],Some condition) ; + d_descr = { + t_source = Lexing.dummy_pos ; + t_short = "equality for " ^ compinfo.corig_name ; + t_descr = "" ; + } ; + } ; cid + end) + +( -------------------------------------------------------------------------- ) +( --- Eq-Array --- ) +( -------------------------------------------------------------------------- ) + +let rec eq_tarray pool te dims ta tb = + match dims with + | [] -> !deq_ctype te ta tb + | d::ds -> + let i = LogicLang.fresh pool "i" Integer in + let ta_i = e_access ta (e_var i) in + let tb_i = e_access tb (e_var i) in + p_forall i + (in_range i d (eq_tarray pool te ds ta_i tb_i)) + +module EqArray = Register(Tarray.Hashtbl) + (struct + type key = Tarray.t + type data = id + let reprs = [LogicId.dummy] + let name = "EqArray" + let compile (te,dims) = + let tau = tau_of_ctype te in + let tau_dim = tau_of_tarray tau dims in + let aid = LogicId.create ("Eq_" ^ tarray_name te dims) in + let pool = LogicLang.pool () in + let a = LogicLang.fresh pool "a" tau_dim in + let b = LogicLang.fresh pool "b" tau_dim in + let condition = eq_tarray pool te dims (e_var a) (e_var b) in + LogicDef.declare { + d_name = aid ; + d_item = PREDICATE([a],Some condition) ; + d_descr = { + t_source = Lexing.dummy_pos ; + t_short = "equality for array" ; + t_descr = "" ; + } ; + } ; aid + end) + +( -------------------------------------------------------------------------- ) +( --- ACSL-Equality --- ) +( -------------------------------------------------------------------------- ) + +let rec eq_ctype typ t1 t2 = eq_object (object_of typ) t1 t2 + +and eq_object obj t1 t2 = + match obj with + | C_int _ -> p_icmp Ceq t1 t2 + | C_float _ -> p_rcmp Ceq t1 t2 + | C_comp c -> p_call (EqComp.obtain c) [t1;t2] + | C_array a -> p_call (EqArray.obtain (tarray_of_arrayinfo a [])) [t1;t2] + | C_pointer _ -> p_equal t1 t2 + +and eq_logic_type lt t1 t2 = + match lt with + | Ctype typ -> eq_ctype typ t1 t2 + | _ -> p_equal t1 t2 ( Stronger for Set, etc. ) + +let () = deq_ctype := eq_ctype + +( -------------------------------------------------------------------------- *) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/ACSL.mli frama-c-20111001+nitrogen+dfsg/src/wp/ACSL.mli --- frama-c-20110201+carbon+dfsg/src/wp/ACSL.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/ACSL.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,81 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Logic Declarations for ACSL ) + +open Ctypes +open Cil_types +open LogicId +open LogicTau +open LogicLang + +( -------------------------------------------------------------------------- *) +(** {2 Types} ) +( -------------------------------------------------------------------------- ) + +val record_of : compinfo -> id +val field_of : fieldinfo -> field + +val tau_of_ctype : typ -> tau +val tau_of_object : c_object -> tau +val tau_of_logic_type : logic_type -> tau + +( -------------------------------------------------------------------------- *) +(** {2 Sub-Types} ) +( -------------------------------------------------------------------------- ) + +val is_int : c_int -> id +val to_int : c_int -> id + +val has_ctype : typ -> term -> pred +val has_object : c_object -> term -> pred + +( -------------------------------------------------------------------------- *) +(** {2 Equality} ) +( -------------------------------------------------------------------------- ) + +val eq_ctype : typ -> term -> term -> pred +val eq_object : c_object -> term -> term -> pred +val eq_logic_type : logic_type -> term -> term -> pred + +( -------------------------------------------------------------------------- *) +(** {2 Declarator Helper} ) +( -------------------------------------------------------------------------- ) + +module type Compiler = +sig + type key + type data + val name : string + val reprs : data list ( Project+Datatype requirement *) + val compile : key -> data +end + +module Register(H : Datatype.Hashtbl)(C : Compiler with type key = H.key) : +sig + + val obtain : C.key -> C.data + (** Projectified and memoized [C.compile]. The compiler can not + be recursive. An exception during the compilation is + re-raised each time its value is requested. *) + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/calculus.ml frama-c-20111001+nitrogen+dfsg/src/wp/calculus.ml --- frama-c-20110201+carbon+dfsg/src/wp/calculus.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/calculus.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,720 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Wp computation using the CFG ) + +open Cil_types +open Cil_datatype + +module Cfg (W : Mcfg.S) = struct + + let dkey = "calculus" ( Debugging key *) + let debug fmt = Wp_parameters.debug ~dkey fmt + + (** Before storing something at a program point, we have to process the label + * at that point. *) + let do_labels wenv e obj = + let do_lab o l = + debug "[do_label] process %a@." Clabels.pretty l; + W.label wenv l o + in + let obj = do_lab obj Clabels.Here in + let labels = Cil2cfg.get_edge_labels e in + let obj = List.fold_left do_lab obj labels in + obj + + let add_hyp wenv obj h = + debug "add hyp %a@." WpPropId.pp_pred_info h; + W.add_hyp wenv h obj + + let add_call_hyp wenv obj h = + debug "add hyp %a@." WpPropId.pp_pred_info h; + W.add_hyp wenv h obj + + let add_goal wenv obj g = + debug "add goal %a@." WpPropId.pp_pred_info g; + W.add_goal wenv g obj + + let add_assigns_goal wenv obj g_assigns = match g_assigns with + | WpPropId.AssignsAny _ | WpPropId.NoAssignsInfo -> obj + | WpPropId.AssignsLocations a -> + debug "add assign goal (@[%s@])@." + (WpPropId.prop_id_name (WpPropId.assigns_info_id a)); + W.add_assigns wenv a obj + + let add_assigns_hyp wenv obj h_assigns = match h_assigns with + | WpPropId.AssignsLocations (h_id, a) -> + let obj = W.use_assigns wenv (Some h_id) a obj in + Some (Clabels.c_label a.WpPropId.a_label), obj + | WpPropId.AssignsAny a -> + let obj = W.use_assigns wenv None a obj in + Some (Clabels.c_label a.WpPropId.a_label), obj + | WpPropId.NoAssignsInfo -> None, obj + + (** detect if the computation of the result at [edge] is possible, + * or if it will loop. If [strategy] are provide, + * cut are done on edges with cut properties, + * and if not, cut are done on loop node back edge if any. + * TODO: maybe this should be done while building the strategy ? + * ) + exception Stop of Cil2cfg.edge + let test_edge_loop_ok cfg strategy edge = + debug "[test_edge_loop_ok] (%s strategy) for %a" + (match strategy with None -> "without" | Some _ -> "with") + Cil2cfg.pp_edge edge; + let rec collect_edge_preds set e = + let cut = + match strategy with None -> Cil2cfg.is_back_edge e + | Some strategy -> + let e_annots = WpStrategy.get_annots strategy e in + (WpStrategy.get_cut e_annots <> []) + in + if cut then () ( normal loop cut ) + else if Cil2cfg.Eset.mem e set + then ( e is already in set : loop without cut ! ) + raise (Stop e) + else ( add e to set and continue with its preds *) + let set = Cil2cfg.Eset.add e set in + let preds = Cil2cfg.pred_e cfg (Cil2cfg.edge_src e) in + List.iter (collect_edge_preds set) preds + in + try + let _ = collect_edge_preds Cil2cfg.Eset.empty edge in + debug "[test_edge_loop_ok] ok."; + true + with Stop e -> + begin + debug "[test_edge_loop_ok] loop without cut detected at %a" + Cil2cfg.pp_edge e; + false + end + + (** to store the results of computations : + * we store a result for each edge, and also a list of proof obligations. + * + * Be careful that there are two modes of computation : + * the first one ([Pass1]) is used to prove the establishment of properties + * while the second (after [change_mode_if_needed]) prove the preservation. + * See {!R.set} for more details. + * ) + module R : sig + type t + val empty : keep:bool -> Cil2cfg.t -> t + val is_pass1 : t -> bool + val change_mode_if_needed : t -> unit + val find : t -> Cil2cfg.edge -> W.t_prop + val set : WpStrategy.strategy -> W.t_env -> + t -> Cil2cfg.edge -> W.t_prop -> W.t_prop + val add_oblig : t -> Clabels.c_label -> W.t_prop -> unit + val add_memo : t -> Cil2cfg.edge -> W.t_prop -> unit + end = + struct + type t_mode = Pass1 | Pass2 + + module HE = Cil2cfg.HE (struct type t = W.t_prop option end) + + module LabObligs : sig + type t + val empty : t + val is_empty : t -> bool + val get_of_label : t -> Clabels.c_label -> W.t_prop list + val get_of_edge : t -> Cil2cfg.edge -> W.t_prop list + val add_to_label : t -> Clabels.c_label -> W.t_prop -> t + val add_to_edge : t -> Cil2cfg.edge -> W.t_prop -> t + end = struct + + type key = Olab of Clabels.c_label | Oedge of Cil2cfg.edge + + let cmp_key k1 k2 = match k1, k2 with + | Olab l1, Olab l2 when l1 = l2 -> true + | Oedge e1, Oedge e2 when Cil2cfg.same_edge e1 e2 -> true + | _ -> false + + ( TODOopt: could have a sorted list... ) + type t = (key W.t_prop list) list + + let empty = [] + + let is_empty obligs = (obligs = []) + + let add obligs k obj = + let rec aux l_obligs = match l_obligs with + | [] -> (k, [obj])::[] + | (k', obligs)::tl when cmp_key k k' -> + (k, obj::obligs)::tl + | o::tl -> o::(aux tl) + in aux obligs + + let add_to_label obligs label obj = add obligs (Olab label) obj + + let add_to_edge obligs e obj = add obligs (Oedge e) obj + + let get obligs k = + let rec aux l_obligs = match l_obligs with + | [] -> [] + | (k', obligs)::_ when cmp_key k k' -> obligs + | _::tl -> aux tl + in aux obligs + + let get_of_label obligs label = get obligs (Olab label) + + let get_of_edge obligs e = get obligs (Oedge e) + + end + + type t = { + mutable mode : t_mode ; + keep_res : bool ; (* whether to keep intermediate results or not ) + cfg: Cil2cfg.t; + tbl : HE.t ; + mutable memo : LabObligs.t; + mutable obligs : LabObligs.t; + } + + let empty ~keep cfg = + debug "start computing (pass 1)@."; + { mode = Pass1; keep_res = keep; cfg = cfg; tbl = HE.create 97 ; + obligs = LabObligs.empty ; memo = LabObligs.empty ;} + + let is_pass1 res = (res.mode = Pass1) + + let add_oblig res label obj = + debug "add proof obligation at label %a =@. @[<hov2> %a@]@." + Clabels.pretty label W.pretty obj; + res.obligs <- LabObligs.add_to_label (res.obligs) label obj + + let add_memo res e obj = + debug "Memo goal for Pass2 at %a=@. @[<hov2> %a@]@." + Cil2cfg.pp_edge e W.pretty obj; + res.memo <- LabObligs.add_to_edge (res.memo) e obj + + let find res e = + let obj = HE.find res.tbl e in + match obj with None -> + Wp_parameters.warning "find edge annot twice (%a) ?" + Cil2cfg.pp_edge e; + raise Not_found + | Some obj -> + if (not res.keep_res) + && (res.mode = Pass2) + && (List.length + (Cil2cfg.pred_e res.cfg (Cil2cfg.edge_src e)) < 2) then + begin + ( it should be used once only : can free it *) + HE.replace res.tbl e None; + debug "clear edge %a@." Cil2cfg.pp_edge e + end; + obj + + (** If needed, clear wp table to compute Pass2. + * If nothing has been stored in res.memo, there is nothing to do. ) + let change_mode_if_needed res = + if LabObligs.is_empty res.memo then () + else + begin + debug "change to Pass2 (clear wp table)@."; + begin try + let e_start = Cil2cfg.start_edge res.cfg in + let start_goal = find res e_start in + add_memo res e_start start_goal + with Not_found -> () + end; + HE.clear res.tbl; + ( move memo obligs of Pass1 to obligs for Pass2 ) + res.obligs <- res.memo; + res.memo <- LabObligs.empty; + res.mode <- Pass2 + end + + let collect_oblig _wenv res e obj = + let labels = Cil2cfg.get_edge_labels e in + let add obj obligs = + List.fold_left (fun obj o -> W.merge (wenv*) o obj) obj obligs + in + let obj = + try + debug "get proof obligation at edge %a@." Cil2cfg.pp_edge e; + let obligs = LabObligs.get_of_edge res.obligs e in + add obj obligs + with Not_found -> obj + in + let add_lab_oblig obj label = + try + debug "get proof obligation at label %a@." Clabels.pretty label; + let obligs = LabObligs.get_of_label res.obligs label in + add obj obligs + with Not_found -> obj + in + let obj = List.fold_left add_lab_oblig obj labels in + obj + + + (** We have found some assigns hypothesis in the stategy : + * it means that we skip the corresponding bloc, ie. we directly compute + * the result before the block : (forall assigns. P), + * and continue with empty. *) + let use_assigns wenv res obj h_assigns = + let lab, obj = add_assigns_hyp wenv obj h_assigns in + match lab with None -> obj + | Some label -> add_oblig res label obj; W.empty + + (** store the result p for the computation of the edge e. + * + * - In Compute mode : + if we have some hyps H about this edge, store H => p + if we have some goal G about this edge, store G /\ p + if we have annotation B to be used as both H and G, store B /\ B=>P + We also have to add H and G from HI (invariants computed in Pass1 mode) + So finaly, we build : [ H => [ BG /\ (BH => (G /\ P)) ] ] + ) + let set strategy wenv res e obj = + try + match (HE.find res.tbl e) with + | None -> raise Not_found + | Some obj -> obj + ( cannot warn here because it can happen with CUT properties. + * We could check that obj is the same thing than the founded result ) + ( Wp_parameters.fatal "strange loop at %a ?" Cil2cfg.pp_edge e ) + with Not_found -> + begin + let e_annot = WpStrategy.get_annots strategy e in + let h_prop = WpStrategy.get_hyp_only e_annot in + let g_prop = WpStrategy.get_goal_only e_annot in + let bh_prop, bg_prop = WpStrategy.get_both_hyp_goals e_annot in + let h_assigns = WpStrategy.get_asgn_hyp e_annot in + let g_assigns = WpStrategy.get_asgn_goal e_annot in + ( get_cut is ignored : see get_wp_edge ) + let obj = collect_oblig wenv res e obj in + let is_loop_head = + match Cil2cfg.node_type (Cil2cfg.edge_src e) with + | Cil2cfg.Vloop (Some _, _) -> true + | _ -> false + in + let compute ~goal obj = + let local_add_goal obj g = + if goal then add_goal wenv obj g else obj + in + let obj = List.fold_left (local_add_goal) obj g_prop in + let obj = List.fold_left (add_hyp wenv) obj bh_prop in + let obj = + if goal then add_assigns_goal wenv obj g_assigns else obj + in + let obj = List.fold_left (local_add_goal) obj bg_prop in + let obj = List.fold_left (add_hyp wenv) obj h_prop in + obj + in + let obj = match res.mode with + | Pass1 -> compute ~goal:true obj + | Pass2 -> compute ~goal:false obj + in + let obj = do_labels wenv e obj in + let obj = + if is_loop_head then obj ( assigns used in [wp_loop] ) + else use_assigns wenv res obj h_assigns + in + debug "[set_wp_edge] %a@." Cil2cfg.pp_edge e; + debug " = @[<hov2> %a@]@." W.pretty obj; + Format.print_flush (); + HE.replace res.tbl e (Some obj); + find res e ( this should give back obj, but also do more things ) + end + + end ( module R ) + + + let use_loop_assigns strategy wenv e obj = + let e_annot = WpStrategy.get_annots strategy e in + let h_assigns = WpStrategy.get_asgn_hyp e_annot in + let label, obj = add_assigns_hyp wenv obj h_assigns in + match label with Some _ -> obj + | None -> assert false ( we should have assigns hyp for loops !) + + let loop_with_cut cfg annots vloop = + let to_loop_edges = Cil2cfg.pred_e cfg vloop in + ( + let back_edges = + List.filter (Cil2cfg.is_back_edge) (Cil2cfg.pred_e cfg vloop) + in *) + List.for_all (test_edge_loop_ok cfg (Some annots)) to_loop_edges + + (** Compute the result for edge [e] which goes to the loop node [nloop]. + * So [e] can be either a back_edge or a loop entry edge. + * Be very careful not to make an infinite loop by calling [get_loop_head]... + * ) + let wp_loop ((_, cfg, strategy, _, wenv)) res nloop e get_loop_head = + let loop_with_cut_pass1 () = + ( simply propagate both for [entry_edge] and [back_edge] ) + debug "[wp_loop] propagate"; + let obj = get_loop_head nloop ( loop should be broken by a cut ) in + let obj = + if Cil2cfg.is_back_edge e then obj + else W.tag "BeforeLoop" obj + in obj + in + let loop_with_quantif () = + if Cil2cfg.is_back_edge e then + ( Be careful not to use get_only_succ here (infinite loop) ) + (debug "[wp_loop] cut at back edge"; + W.empty) + else ( edge going into the loop from outside : quantify ) + begin + debug "[wp_loop] quantify"; + let obj = get_loop_head nloop in + let head = match Cil2cfg.succ_e cfg nloop with + | [h] -> h + | _ -> assert false ( already detected in [get_loop_head] ) + in use_loop_assigns strategy wenv head obj + end + in + if WpStrategy.new_loop_computation strategy + && R.is_pass1 res + && loop_with_cut cfg strategy nloop + then + loop_with_cut_pass1 () + else ( old mode or no inv or pass2 ) + match Cil2cfg.node_type nloop with + | Cil2cfg.Vloop (Some true, _) -> ( natural loop (has back edges) ) + loop_with_quantif () + | _ -> ( TODO : print info about the loop ) + Wp_error.unsupported + "non-natural loop without invariant property." + + let wp_call ((_, cfg, strategy, _, wenv)) v stmt res fct args p_post p_exit = + debug "[wp_call] %a@." !Ast_printer.d_exp fct; + let eb = match Cil2cfg.pred_e cfg v with e::_ -> e | _ -> assert false in + let en, ee = Cil2cfg.get_call_out_edges cfg v in + let eb_annot = WpStrategy.get_annots strategy eb in + let en_annot = WpStrategy.get_annots strategy en in + let ee_annot = WpStrategy.get_annots strategy ee in + let call_asgn = WpStrategy.get_call_asgn en_annot in + match WpStrategy.get_called_kf fct with + | None -> + let obj = W.merge p_post p_exit in + let lab, obj = add_assigns_hyp wenv obj call_asgn in + let obj = match lab with Some _ -> obj + | None -> assert false + ( we should always have some information, + * even if it is only assigns everything. ) + in obj + | Some kf -> + let assigns = match call_asgn with + | WpPropId.AssignsLocations (_, asgn_body) -> + asgn_body.WpPropId.a_assigns + | WpPropId.AssignsAny _ -> WritesAny + | WpPropId.NoAssignsInfo -> assert false ( see above ) + in + let pre_hyp, pre_goals = WpStrategy.get_call_pre eb_annot in + let obj = W.call wenv stmt res kf args + ~pre:(pre_hyp) + ~post:((WpStrategy.get_call_hyp en_annot)) + ~pexit:((WpStrategy.get_call_hyp ee_annot)) + ~assigns ~p_post ~p_exit + in W.call_goal_precond wenv stmt kf args ~pre:(pre_goals) obj + + let wp_stmt wenv s obj = match s.skind with + | Return (r, _) -> W.return wenv r obj + | Instr i -> + begin match i with + | (Set (lv, e, _)) -> W.assign wenv lv e obj + | (Call _) -> assert false + | (Asm _) -> + Wp_parameters.warning + "Unsupported inline assembler. Assuming no effects.@."; + obj + | Skip _ | Code_annot _ -> obj + end + | Break _ | Continue _ | Goto _ -> obj + | Loop _-> ( this is not a real loop (exit before looping) + just ignore it ! *) obj + | If _ -> assert false + | Switch _-> assert false + | Block _-> assert false + | UnspecifiedSequence _-> assert false + | TryExcept _ | TryFinally _ -> assert false + + let wp_scope wenv vars scope obj = + debug "[wp_scope] %s : %a@." + (match scope with + | Mcfg.SC_Global -> "global" + | Mcfg.SC_Block_in -> "block in" + | Mcfg.SC_Block_out -> "block out" + | Mcfg.SC_Function_in -> "function in" + | Mcfg.SC_Function_frame -> "function frame" + | Mcfg.SC_Function_out -> "function out" ) + (Pretty_utils.pp_list ~sep:", " !Ast_printer.d_var) vars; + W.scope wenv vars scope obj + + + (** @return the WP stored for edge [e]. Compute it if it is not already + * there and store it. Also handle the Acut annotations. ) + let rec get_wp_edge ((_kf, cfg, strategy, res, wenv) as env) e = + !Db.progress (); + let v = Cil2cfg.edge_dst e in + debug "[get_wp_edge] get wp before %a@." Cil2cfg.pp_node v; + try + let res = R.find res e in + debug "[get_wp_edge] %a already computed@." Cil2cfg.pp_node v; + res + with Not_found -> + ( Notice that other hyp and goal are handled in R.set as usual ) + let cutp = + if R.is_pass1 res + then WpStrategy.get_cut (WpStrategy.get_annots strategy e) + else [] + in + match cutp with + | [] -> + let wp = compute_wp_edge env e in + R.set strategy wenv res e wp + | cutp -> + debug "[get_wp_edge] cut at node %a@." Cil2cfg.pp_node v; + let add_cut_goal (g,p) acc = + if g then add_goal wenv acc p else acc + in + let edge_annot = List.fold_right add_cut_goal cutp W.empty in + ( put cut goal properties as goals in e if any, else true ) + let edge_annot = R.set strategy wenv res e edge_annot in + let wp = compute_wp_edge env e in + let add_cut_hyp (_,p) acc = add_hyp wenv acc p in + let oblig = List.fold_right add_cut_hyp cutp wp in + ( TODO : we could add hyp to the oblig if we have some in strategy ) + let oblig = W.tag "InLoop" oblig in + if test_edge_loop_ok cfg None e + then R.add_memo res e oblig + else R.add_oblig res Clabels.Pre (W.close wenv oblig); + edge_annot + + and get_only_succ env cfg v = match Cil2cfg.succ_e cfg v with + | [e'] -> get_wp_edge env e' + | ls -> Wp_parameters.fatal "CFG node %a has %d successors instead of 1@." + Cil2cfg.pp_node v (List.length ls) + + and compute_wp_edge ((kf, cfg, _annots, res, wenv) as env) e = + let v = Cil2cfg.edge_dst e in + debug "[compute_edge] before %a go...@." Cil2cfg.pp_node v; + let old_loc = Cil.CurrentLoc.get () in + let () = match Cil2cfg.node_stmt_opt v with + | Some s -> Cil.CurrentLoc.set (Stmt.loc s) + | None -> () + in + let formals = Kernel_function.get_formals kf in + let res = match Cil2cfg.node_type v with + | Cil2cfg.Vstart -> + Wp_parameters.fatal "No CFG edge can lead to Vstart" + | Cil2cfg.VfctIn -> + let obj = get_only_succ env cfg v in + let obj = wp_scope wenv formals Mcfg.SC_Function_in obj in + let obj = wp_scope wenv [] Mcfg.SC_Global obj in + obj + | Cil2cfg.VblkIn (Cil2cfg.Bfct, b) -> + let obj = get_only_succ env cfg v in + let obj = wp_scope wenv b.blocals Mcfg.SC_Block_in obj in + wp_scope wenv formals Mcfg.SC_Function_frame obj + | Cil2cfg.VblkIn (_, b) -> + let obj = get_only_succ env cfg v in + wp_scope wenv b.blocals Mcfg.SC_Block_in obj + | Cil2cfg.VblkOut (_, _b) -> + let obj = get_only_succ env cfg v in + obj ( cf. blocks_closed_by_edge below ) + | Cil2cfg.Vstmt s -> + let obj = get_only_succ env cfg v in + wp_stmt wenv s obj + | Cil2cfg.Vcall (stmt, res, fct, args) -> + let en, ee = Cil2cfg.get_call_out_edges cfg v in + let objn = get_wp_edge env en in + let obje = get_wp_edge env ee in + wp_call env v stmt res fct args objn obje + | Cil2cfg.Vtest (true, _, c) -> + let et, ef = Cil2cfg.get_test_edges cfg v in + let t_obj = get_wp_edge env et in + let f_obj = get_wp_edge env ef in + W.test wenv c t_obj f_obj + | Cil2cfg.Vtest (false, _, _) -> + get_only_succ env cfg v + | Cil2cfg.Vswitch (_, e) -> + let cases, def_edge = Cil2cfg.get_switch_edges cfg v in + let cases_obj = List.map (fun (c,e) -> c, get_wp_edge env e) cases in + let def_obj = get_wp_edge env def_edge in + W.switch wenv e cases_obj def_obj + | Cil2cfg.Vloop _ | Cil2cfg.Vloop2 _ -> + let get_loop_head = fun n -> get_only_succ env cfg n in + wp_loop env res v e get_loop_head + | Cil2cfg.VfctOut + | Cil2cfg.Vexit -> + let obj = get_only_succ env cfg v ( exitpost / postcondition ) in + wp_scope wenv formals Mcfg.SC_Function_out obj + | Cil2cfg.Vend -> + W.empty +( LC : unused entry point... + let obj = W.empty in + wp_scope wenv formals Mcfg.SC_Function_after_POST obj +) + in + let res = + let blks = Cil2cfg.blocks_closed_by_edge cfg e in + let free_locals res b = wp_scope wenv b.blocals Mcfg.SC_Block_out res in + List.fold_left free_locals res blks + in + debug "[compute_edge] before %a done@." Cil2cfg.pp_node v; + Cil.CurrentLoc.set old_loc; + res + + ( Hypothesis for initialization of one global variable ) + let rec init_global_variable wenv lv init obj = + match init with + + | SingleInit exp -> + W.init_value wenv lv (Cil.typeOfLval lv)(Some exp) obj + + | CompoundInit ( ct , initl ) -> + + let len = List.length initl in + let implicit_defaults = + match ct with + | TArray (ty,Some {enode = (Const CInt64 (size,_,_))},_,_) + when My_bigint.lt (My_bigint.of_int len) size -> + + W.init_range wenv lv ty + (Int64.of_int len) (My_bigint.to_int64 size) obj + + | TComp (cp,_,_) when len < (List.length cp.cfields) -> + + List.fold_left + (fun obj f -> + if List.exists + (function (Field(g,_),_) -> Fieldinfo.equal f g | _ -> false) + initl + then obj + else + W.init_value wenv + (Cil.addOffsetLval (Field(f, NoOffset)) lv) + f.ftype None obj) + obj (List.rev cp.cfields) + + | _ -> obj + in + List.fold_left + (fun obj (off,init) -> + let lv = Cil.addOffsetLval off lv in + init_global_variable wenv lv init obj) + implicit_defaults (List.rev initl) + + + ( WP of global initialisations. ) + let process_global_init wenv kf obj = + if WpStrategy.is_main_init kf then + List.fold_left + (fun obj global -> + match global with + | GVar (var, initinfo, loc) -> + if var.vstorage = Extern then obj + else + let old_loc = Cil.CurrentLoc.get () in + Cil.CurrentLoc.set loc ; + let obj = + match initinfo.init with + | None -> + W.init_value + wenv (Var var,NoOffset) var.vtype None obj + | Some init -> + let lv = Var var, NoOffset in + init_global_variable wenv lv init obj + in Cil.CurrentLoc.set old_loc ; obj + | _ -> obj + ) obj (Ast.get()).globals + else + obj + + let get_weakest_precondition cfg ((kf, _g, strategy, res, wenv) as env) = + debug "[wp-cfg] start Pass1"; + Cil2cfg.iter_edges (fun e -> ignore (get_wp_edge env e)) cfg ; + debug "[wp-cfg] end of Pass1"; + R.change_mode_if_needed res; + ( Notice that [get_wp_edge] will start Pass2 if needed, + * but if not, it will only fetch Pass1 result. ) + let e_start = Cil2cfg.start_edge cfg in + let obj = get_wp_edge env e_start in + let obj = process_global_init wenv kf obj in + let obj = match WpStrategy.strategy_kind strategy with + | WpStrategy.SKannots -> obj + | WpStrategy.SKfroms info -> + let pre = info.WpStrategy.get_pre () in + let pre = WpStrategy.get_hyp_only pre in + W.build_prop_of_from wenv pre obj + in + debug "before close: %a@." W.pretty obj; + W.close wenv obj + + let add_axiom (id, (name,labels,p)) = + W.add_axiom id name labels p + + let compute cfg strategy = + debug "[wp-cfg] start computing with the strategy for %a" + WpStrategy.pp_info_of_strategy strategy; + if WpStrategy.strategy_has_prop_goal strategy + || WpStrategy.strategy_has_asgn_goal strategy then + try + let kf = Cil2cfg.cfg_kf cfg in + + if WpStrategy.new_loop_computation strategy then + (match Cil2cfg.very_strange_loops cfg with [] -> () + | _ -> ( TODO : print info about the loops ) + Wp_error.unsupported "strange loop(s).") + else + (match Cil2cfg.strange_loops cfg with [] -> () + | _ -> ( TODO : print info about the loops *) + Wp_error.unsupported + "non natural loop(s): try [-wp-invariants] option"); + + let lvars = match WpStrategy.strategy_kind strategy with + | WpStrategy.SKfroms info -> info.WpStrategy.more_vars + | _ -> [] + in + let wenv = W.new_env ~lvars kf in + let keep = if Wp_parameters.Dot.get () then true else false in + let res = R.empty ~keep cfg in + let env = (kf, cfg, strategy, res, wenv) in + List.iter add_axiom (WpStrategy.global_axioms strategy) ; + let goal = get_weakest_precondition cfg env in + debug "[get_weakest_precondition] %a@." W.pretty goal; + let pp_cfg_edges_annot res fmt e = + try W.pretty fmt (R.find res e) + with Not_found -> Format.fprintf fmt "<released>" + in + let annot_cfg = pp_cfg_edges_annot res in + debug "[wp-cfg] computing done."; + [goal] , annot_cfg + with Wp_error.Error (_, msg) -> + Wp_parameters.warning "@[calculus failed on strategy@ @[for %a@]@ \ + because@ %s (abort)@]" + WpStrategy.pp_info_of_strategy strategy + msg; + let annot_cfg fmt _e = Format.fprintf fmt "" in + [], annot_cfg + else + begin + debug "[wp-cfg] no goal in this strategy : ignore."; + let annot_cfg fmt _e = Format.fprintf fmt "" in + [], annot_cfg + end + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/calculus.mli frama-c-20111001+nitrogen+dfsg/src/wp/calculus.mli --- frama-c-20110201+carbon+dfsg/src/wp/calculus.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/calculus.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,37 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* $Id: calculus.mli 15451 2011-10-04 11:34:51Z signoles $ *) + +open Cil_types + +(** Generic WP calculus ) + +module Cfg(W : Mcfg.S) : +sig + + val compute : + Cil2cfg.t -> + WpStrategy.strategy -> + W.t_prop list (Format.formatter -> Cil2cfg.edge -> unit) + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/cfgProof.ml frama-c-20111001+nitrogen+dfsg/src/wp/cfgProof.ml --- frama-c-20110201+carbon+dfsg/src/wp/cfgProof.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/cfgProof.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,334 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types +open Cfgpropid + +let dkey = "cfgproof" (* debugging key *) + +class type computer = +object + + method add : WpStrategy.strategy list -> unit + method compute : Wpo.t list + +end + +module type Description = +sig + + val shared : string (** Shared resource basename for the model *) + val context : string (** Basename for environment files ; unique per updater *) + val updater : string (** Unique name for the internal updater *) + val name : string (** Public name for user feedback ) + +end + +module Create + (WpModel:Mwp.S) + (Why:Mcfg.Export with type pred = WpModel.F.pred and type decl = WpModel.F.decl) + (Coq:Mcfg.Export with type pred = WpModel.F.pred and type decl = WpModel.F.decl) + (Ergo:Mcfg.Export with type pred = WpModel.F.pred and type decl = WpModel.F.decl) + (Splitter:Mcfg.Splitter with type pred = WpModel.F.pred) + (Descr:Description) + = +struct + + module Me = State_builder.Ref + (Datatype.Unit) + (struct + let dependencies = [Ast.self] + let name = "WP-" ^ Descr.updater + let kind = `Correctness + let default () = () + end) + + module F = WpModel.F + module L = WpModel.L + module CV = + CfgWeakestPrecondition.Create + (struct + include WpModel + let model = Descr.updater + end) + module PO = Cfgpropid.Create(CV) + module WP = Calculus.Cfg(PO) + + ( ------------------------------------------------------------------------ ) + ( --- Proof Obligations : Export to WHY --- ) + ( ------------------------------------------------------------------------ ) + + type exportation = { + env : string ; + mutable goals : Wpo.t list ; + } + + let assigns_method = PO.assigns_method + + ( ------------------------------------------------------------------------ ) + ( --- Goal Registering --- ) + ( ------------------------------------------------------------------------ ) + + let active_lgg () = + match Wpo.language_of_prover_name (Wp_parameters.Prover.get ()) with + | None -> + (match Wpo.language_of_name (Wp_parameters.Check.get ()) with + | None -> None + | Some l -> Some l + ) + | Some l -> Some l + + let export_wpo export kf bhv wrn dep propid gpred = + let gname = WpPropId.prop_id_name propid in + let gid = Wpo.gid ~context:Descr.context ~kf ~bhv ~propid in + ( --- HEADER --- ) + Wp_parameters.debug ~dkey "Export PO %s " gname; + let fhead = Wpo.file_for_head ~gid in + Wp_parameters.debug ~dkey "DO HEADER in %s" fhead ; + Command.pp_to_file fhead + (fun fmt -> + Format.fprintf fmt "@[<v 0>Proof Obligation %s:@]@\n" gname ; + Format.fprintf fmt "Environment: %s@\n" export.env ; + List.iter (fun d -> Format.fprintf fmt "%a@\n" (Wpo.pp_dependency kf) d) dep ; + List.iter (fun w -> Format.fprintf fmt "%a@\n" Wpo.pp_warning w) wrn ; + ) ; + Wp_parameters.debug ~dkey "DONE HEADER in %s" fhead; + ( --- BODY --- ) + let fbody = Wpo.file_for_body ~gid in + Wp_parameters.debug ~dkey "DO BODY in %s" fbody ; + Command.pp_to_file fbody + (fun fmt -> + Format.fprintf fmt "@[<v 2>Goal %s:@ %a@]" gid F.pp_pred gpred ; + ) ; + Wp_parameters.debug ~dkey "DONE BODY in %s" fbody ; + ( --- WHY Others --- ) + let export_lgg l = + Wp_parameters.debug ~dkey "DO export goal in language %a" + Wpo.pp_language l; + Command.pp_to_file (Wpo.file_for_goal ~gid l ) + (fun fmt -> + match l with + | Wpo.L_why -> Why.export_goal fmt gid gpred + | Wpo.L_coq -> Coq.export_goal fmt gid gpred + | Wpo.L_altergo -> Ergo.export_goal fmt gid gpred + ) ; + Wp_parameters.debug ~dkey "DONE export goal in language %a" + Wpo.pp_language l; + in + + let export_all () = + export_lgg Wpo.L_why ; + export_lgg Wpo.L_coq ; + export_lgg Wpo.L_altergo; + in + ( + if !Config.is_gui || (Wp_parameters.debug_atleast 2) then + (Wp_parameters.debug ~dkey + "Into gui config, goal has to be produce in all languages"; + export_all () ) + else + (match active_lgg () with + | None -> () + | Some l ->export_lgg l + ) + ); + + ( --- Warnings --- ) + if wrn <> [] then + begin + let pp_warnings fmt ws = + let n = List.length ws in if n = 1 + then Format.pp_print_string fmt "1 warning" + else Format.fprintf fmt "%d warnings" n + in + let degenerated = List.exists (fun w -> w.Wpo.wrn_severe) wrn in + if not (Wp_parameters.Details.get ()) then + Wp_parameters.warning ~current:false ~once:true + "Use -wp-warnings for details about 'Stronger' and 'Degenerated' goals" ; + Wp_parameters.warning ~current:false + "%s goal %s (%a)" + (if degenerated then "Degenerated" else "Stronger") + gid pp_warnings wrn ; + if Wp_parameters.Details.get () then + List.iter + (fun w -> + Log.print_on_output + (fun fmt -> Wpo.pp_warning fmt w ; Format.pp_print_newline fmt ()) + ) wrn ; + end ; + + let emitter = + Emitter.create Me.name + ~correctness:[] ~tuning:[ Wp_parameters.Prover.parameter ] + in + + ( --- WPO --- ) + let wpo = { + Wpo.po_fun = kf ; + Wpo.po_bhv = bhv ; + Wpo.po_name = gname ; + Wpo.po_gid = gid ; + Wpo.po_model = Descr.shared ; + Wpo.po_env = export.env ; + Wpo.po_pid = propid ; + Wpo.po_dep = dep ; + Wpo.po_warn = wrn ; + Wpo.po_updater = emitter; + } + in + Wpo.add wpo ; + if F.is_true gpred then + Wpo.set_result wpo Wpo.WP Wpo.Valid ; + export.goals <- wpo :: export.goals + + ( ------------------------------------------------------------------------ ) + ( --- Goal Splitting --- ) + ( ------------------------------------------------------------------------ ) + + let build_wpos export kf bhv wrn dep propid gpred = + let gpred = Splitter.simplify gpred in + if Wp_parameters.Split.get () || Wp_parameters.Invariants.get () || + (WpPropId.is_assigns propid && PO.assigns_method() = Mcfg.EffectAssigns) + then + let goals = Splitter.split (PO.assigns_method ()) gpred in + if Bag.is_empty goals then + export_wpo export kf bhv wrn dep propid F.p_true + else + WpAnnot.split (export_wpo export kf bhv wrn dep) propid goals + else + export_wpo export kf bhv wrn dep propid gpred + + let add_goal export kf bhv po = + let gpred = CV.zip po.PO.g_prop in + let wrn = ref [] in + let dep = ref [] in + PO.iter_description + (fun w -> wrn := w :: !wrn) + (fun d -> dep := d :: !dep) + po.PO.g_descr ; + build_wpos export kf bhv (List.rev !wrn) (List.rev !dep) po.PO.g_id gpred + + ( ------------------------------------------------------------------------ ) + ( --- Proof Obilgation Generation --- ) + ( ------------------------------------------------------------------------ ) + + class computer = + object + + val mutable wptasks = [] + val mutable exported = None + + method add strategies = + wptasks <- strategies :: wptasks + + method compute = + begin + + exported <- None ; + Wp_error.set_model Descr.name ; + F.clear () ; + let env = Wpo.new_env ~context:Descr.context in + let export = { env=env ; goals=[] } in + + ( Generates Wpos and accumulate exported goals ) + List.iter + (fun (strategies) -> + List.iter + (fun strategy -> + let cfg = WpStrategy.cfg_of_strategy strategy in + let kf = Cil2cfg.cfg_kf cfg in + let names = WpAnnot.missing_rte kf in + if names <> [] then + Wp_parameters.warning ~current:false ~once:true + "Missing RTE guards" ; + !Db.progress (); + let bhv = WpStrategy.behavior_name_of_strategy strategy in + let goals,annotations = WP.compute cfg strategy in + if Wp_parameters.Dot.get () then + ignore (Cil2cfg.dot_wp_res cfg Descr.shared annotations) ; + List.iter + (List.iter + (add_goal export kf bhv)) + goals + ) strategies + ) wptasks ; + + if export.goals <> [] then + begin + + ( --- Env Description --- ) + let ctxt = Wpo.file_for_ctxt ~env in + Wp_parameters.debug ~dkey "DO ENV DESCP %s" ctxt ; + Command.pp_to_file ctxt + (fun fmt -> F.iter_all (F.pp_section fmt) (F.pp_decl fmt)) ; + Wp_parameters.debug ~dkey "DONE ENV DESCP %s" ctxt ; + + let export_env_lgg l = + Wp_parameters.debug ~dkey "DO export env for %a" Wpo.pp_language l ; + Command.pp_to_file (Wpo.file_for_env ~env l) + (fun fmt -> + match l with + | Wpo.L_coq -> Format.fprintf fmt + "Require Import Reals.@\n\ + Require Import wp.@\n\ + Require Import %s.@\n" + (Wpo.coq_for_model Descr.shared) ; + F.iter_all (Coq.export_section fmt) (Coq.export_decl fmt) + | Wpo.L_why -> + F.iter_all (Why.export_section fmt) (Why.export_decl fmt) + | Wpo.L_altergo -> + F.iter_all (Ergo.export_section fmt) (Ergo.export_decl fmt) + ) + in + if !Config.is_gui || Wp_parameters.debug_atleast 2 then + begin + export_env_lgg Wpo.L_why ; + export_env_lgg Wpo.L_coq ; + export_env_lgg Wpo.L_altergo ; + end + else + begin + match active_lgg () with + | None -> () + | Some l -> export_env_lgg l + end + + end + else + Wpo.release_env env ; + + ( --- Generated Goals --- ) + export.goals + + end ( method compute ) + + end ( class computer ) + + let create () = (new computer :> computer) + +end + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/cfgpropid.ml frama-c-20111001+nitrogen+dfsg/src/wp/cfgpropid.ml --- frama-c-20110201+carbon+dfsg/src/wp/cfgpropid.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/cfgpropid.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,317 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types + +type dnode = { + dn_id : int; + dn_warn : Wpo.warning list; + dn_depends : Property.t list; + dn_source : dnode list; +} + +module Sint = Set.Make + (struct type t = int let compare = Datatype.Int.compare end) + +let iter_dnodes f d = + let rec iter marked f d = + if not (Sint.mem d.dn_id !marked) then + ( (f d:unit) ; marked := Sint.add d.dn_id !marked ; + List.iter (iter marked f) d.dn_source ) + in iter (ref Sint.empty) f d + +let pp_list pp fmt xs = + List.iter (fun x -> pp fmt x ; Format.pp_print_newline fmt ()) xs + +let pp_dnode fmt d = + iter_dnodes + (fun d -> + pp_list Wpo.pp_warning fmt d.dn_warn ; + pp_list Wpo.pp_depend fmt d.dn_depends ; + ) d + +module Create (W : Mcfg.S) = +struct + + type t_env = W.t_env + let new_env = W.new_env + + type description = dnode + + type t_goal = { + g_id : WpPropId.prop_id ; + g_prop : W.t_prop; + g_descr : dnode; + } + + type t_prop = t_goal list + + let pp_goal fmt name g = + begin + Format.fprintf fmt "@[<v 0>Proof Obligation %a:@]@\n" WpPropId.pp_id_name g.g_id ; + pp_dnode fmt g.g_descr ; + Format.fprintf fmt "@[<v 2>Goal %s:@ %a@]@." name W.pretty g.g_prop ; + end + + let pp_descr fmt g = + Format.fprintf fmt "Proof Obligation for %a:@\n" + WpPropId.pretty g.g_id ; + pp_dnode fmt g.g_descr + + let iter_description fwrn fdep d = + iter_dnodes + (fun d -> + List.iter fwrn d.dn_warn ; + List.iter fdep d.dn_depends ; + ) d + + let pp_goalx fmt g = pp_goal fmt "" g + + let pretty = pp_list pp_goalx + + let empty = [] + + let dnode_cpt = ref 0 + + let make_goal prop_id process dsource = + let collect = Datalib.Collector.push () in + let p = + try process () + with e -> + ignore (Datalib.Collector.pop collect) ; + (* TODO : catch the exception here to not break the wp calculus ) + raise e + in + let warns, depends = Datalib.Collector.pop collect in + let id = incr dnode_cpt; !dnode_cpt in + let dn = { + dn_id = id ; + dn_warn = warns ; + dn_depends = depends ; + dn_source = dsource ; + } in { + g_id = prop_id ; + g_prop = p ; + g_descr = dn ; + } + + let rec merge goals1 goals2 = + ( List.merge sort_obligs opl1 opl2 : no, because keeps duplicates *) + match goals1, goals2 with + | _, [] -> goals1 + | [], _ -> goals2 + | g1::tl1, g2::tl2 -> + let cmp = WpPropId.compare_prop_id g1.g_id g2.g_id in + if cmp < 0 then g1::(merge tl1 goals2) + else if cmp > 0 then g2::(merge goals1 tl2) + else + let g = make_goal g1.g_id + (fun () -> W.merge g1.g_prop g2.g_prop) + [g1.g_descr; g2.g_descr] + in g::(merge tl1 tl2) + + let add_hyp env h goals = + let f p () = W.add_hyp env h p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let build_prop_of_from env pre goals = + let f p () = W.build_prop_of_from env pre p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let add_goal env g goals = + let new_prop () = W.add_goal env g W.empty in + let g = make_goal (WpPropId.pred_info_id g) new_prop [] in + merge [g] goals + + let add_axiom id name labels axiom = + let collect = Datalib.Collector.push () in + W.add_axiom id name labels axiom; + let warns, depends = Datalib.Collector.pop collect in + begin + List.iter + (fun w -> + Wp_parameters.warning "Warning for Axiom %s:@\nFrom %s: %s@\nEffect: %s" + name w.Wpo.wrn_source w.Wpo.wrn_reason w.Wpo.wrn_effect) + warns ; + List.iter + (fun d -> + Wp_parameters.warning "Warning for Axiom %s:@\nDepends on %a" + name Description.pp_property d) + depends ; + end + + let add_assigns env assigns goals = + let f () = W.add_assigns env assigns W.empty in + let new_goal = make_goal (WpPropId.assigns_info_id assigns) f [] in + if new_goal.g_prop = W.empty then goals + else merge [new_goal] goals + + let assigns_method = W.assigns_method + + let init_value env lv ty e_opt goals = + let f p () = W.init_value env lv ty e_opt p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let init_range env lv ty ka kb goals = + let f p () = W.init_range env lv ty ka kb p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let assign env lv e goals = + let f p () = W.assign env lv e p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let return env e goals = + let f p () = W.return env e p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let test env c goals_t goals_f = + let test pt pf () = W.test env c pt pf in + let rec merge lt lf = match lt, lf with + | [], [] -> [] + | g::lt, [] -> + let dsource = [g.g_descr] in + let g = make_goal g.g_id (test g.g_prop W.empty) dsource in + g::(merge lt lf) + | [], g::lf -> + let dsource = [g.g_descr] in + let g = make_goal g.g_id (test W.empty g.g_prop) dsource in + g::(merge lt lf) + | gt::tlt, gf::tlf -> + let cmp = WpPropId.compare_prop_id gt.g_id gf.g_id in + if cmp < 0 then + let dsource = [gt.g_descr] in + let g = make_goal gt.g_id (test gt.g_prop W.empty) dsource in + g::(merge tlt lf) + else if cmp > 0 then + let dsource = [gf.g_descr] in + let g = make_goal gf.g_id (test W.empty gf.g_prop) dsource in + g::(merge lt tlf) + else + let dsource = [gt.g_descr; gf.g_descr] in + let g = make_goal gf.g_id (test gt.g_prop gf.g_prop) dsource in + g::(merge tlt tlf) + in merge goals_t goals_f + + (** merge the switch branches : + * @param e : switch expression, + * @param cases : a list of (case expression, wp for that case), + * @param p_def : wp for the default branch. + * Because each wp is a list, it is not so easy to merge. + * So we decide to chose a simple, but not optimized, algorithm : + * - we first collect a sorted list of all the ids in every branches, + * - we then process each id but getting the wp for this id in each branch, + * - and we then put back things together. + ) + let switch env e cases p_def = + let rec add_id ids new_id = match ids with [] -> [new_id] + | id::other_ids -> let cmp = WpPropId.compare_prop_id new_id id in + if cmp = 0 then ids ( new_id already in ) + else if cmp < 0 then new_id::ids + else id::(add_id other_ids new_id) + in + let collect_id ids g = add_id ids g.g_id in + let collect_ids ids (_, lp) = List.fold_left collect_id ids lp in + let ids = List.map (fun g -> g.g_id) p_def in + let ids = List.fold_left collect_ids ids cases in + ( we now have all the ids found in all the lists ) + let get_p_id id goals = + try + let g = + List.find (fun g -> WpPropId.compare_prop_id id g.g_id = 0) goals + in g.g_prop + with Not_found -> W.empty + in + let get_descr_id id = + let add_goal acc g = + if WpPropId.compare_prop_id id g.g_id = 0 then g.g_descr::acc + else acc + in + let add_goals = List.fold_left add_goal in + let acc = add_goals [] p_def in + List.fold_left (fun acc (_, gs) -> add_goals acc gs) acc cases + in + let process_id id = + let id_p_def = get_p_id id p_def in + let id_cases = + List.map (fun (cond, lp) -> (cond, get_p_id id lp)) cases + in + let f () = W.switch env e id_cases id_p_def in + let d = get_descr_id id in + make_goal id f d + in List.map process_id ids ( ids are sorted => goals are also sorted ) + + ( -------------------------------------------------------------------------- ) + ( --- Call Rules --- ) + ( -------------------------------------------------------------------------- *) + + let call_goal_precond wenv stmt kf args ~pre goals = + let new_prop p () = + W.call_goal_precond wenv stmt kf args ~pre:[p] W.empty + in + let preconds = + List.map + (fun p -> make_goal (WpPropId.pred_info_id p) (new_prop p) []) pre + in + merge preconds goals + + let call wenv stmt lv kf args ~pre ~post ~pexit ~assigns ~p_post ~p_exit = + let wp ~post ~pexit p_post p_exit () = + W.call wenv stmt lv kf args + ~pre ~post ~pexit ~assigns ~p_post ~p_exit + in + let g_post = + List.map + (fun g -> + make_goal g.g_id (wp ~post ~pexit:[] g.g_prop W.empty) + [g.g_descr]) + p_post + in + let g_exit = + List.map + (fun g -> + make_goal g.g_id (wp ~post:[] ~pexit W.empty g.g_prop) + [g.g_descr]) + p_exit + in + merge g_post g_exit + + let use_assigns env id assigns goals = + let f p () = W.use_assigns env id assigns p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let label env l goals = + let f p () = W.label env l p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let scope env vars sc goals = + let f p () = W.scope env vars sc p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let close env goals = + let f p () = W.close env p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + + let tag t goals = + let f p () = W.tag t p in + List.map (fun g -> make_goal g.g_id (f g.g_prop) [g.g_descr]) goals + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/cfgpropid.mli frama-c-20111001+nitrogen+dfsg/src/wp/cfgpropid.mli --- frama-c-20110201+carbon+dfsg/src/wp/cfgpropid.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/cfgpropid.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,45 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Indexed goals by [prop_id] *) + +module Create (W : Mcfg.S) : +sig + type description + type t_goal = { + g_id : WpPropId.prop_id ; + g_prop : W.t_prop; + g_descr : description; + } + + val pp_goal : Format.formatter -> string -> t_goal -> unit + + val pp_descr : Format.formatter -> t_goal -> unit + + val iter_description : + (Wpo.warning -> unit) -> + (Property.t -> unit) -> + description -> unit + + include Mcfg.S with type t_prop = t_goal list + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/cfgWeakestPrecondition.ml frama-c-20111001+nitrogen+dfsg/src/wp/cfgWeakestPrecondition.ml --- frama-c-20110201+carbon+dfsg/src/wp/cfgWeakestPrecondition.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/cfgWeakestPrecondition.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,880 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Generator of Preconditions --- ) +( -------------------------------------------------------------------------- ) + +open Cil_types +open Wp_error + +module Create + (WpModel: + sig + include Mwp.S + val model : string + end) + = +struct + + module F = WpModel.F + module D = WpModel.L + module E = Translate_expr.Create(WpModel) + module L = Translate_prop.Create(WpModel) + + let predicate = Wp_error.protect_translation L.prop + let expr = Wp_error.protect_translation E.expr + let addr = Wp_error.protect_translation E.addr + let cond = Wp_error.protect_translation E.prop + let cast = Wp_error.protect_translation3 E.expr_cast + + type t_env = F.pool L.env + + type t_prop = assigns_kind * property + + and property = { + bindings : D.bindings ; + property : F.pred ; + } + + and assigns_kind = + | NoAssigns + | EffectAssigns of effect_assigns + + and effect_assigns = { + a_pid : WpPropId.prop_id ; + a_label : Clabels.c_label ; + a_effect : F.var ; (* accumulated zones for effects ) + a_locals : F.var ; ( accumulated zones for local variables ) + } + + + let empty = NoAssigns , { + bindings = D.closed ; + property = F.p_true ; + } + + let zip (_,omega) = + D.close omega.bindings omega.property + + let merge_assigns s1 s2 = + match s1,s2 with + | NoAssigns,NoAssigns -> NoAssigns + | NoAssigns,a -> a + | a,NoAssigns -> a + | EffectAssigns a1 , EffectAssigns a2 when a1 == a2 -> s1 + | _ -> Wp_parameters.fatal "Merging different assigns goals" + + let merge_property f w1 w2 = + { + bindings=D.closed ; + property=f + (D.close w1.bindings w1.property) + (D.close w2.bindings w2.property) ; + } + + let is_empty (_,p) = F.is_true p.property + + let merge (s1,p1) (s2,p2) = + if F.is_true p2.property then (s1,p1) else + if F.is_true p1.property then (s2,p2) else + merge_assigns s1 s2 , merge_property F.p_and p1 p2 + + let pretty fmt wp = F.pp_pred fmt (zip wp) + + let new_env ?(lvars=[]) kf = + let pool = F.pool () in + pool, L.add_logic_vars (L.env kf ()) pool lvars + + type closing = + | Keep_opened + | Close_context + + type assigns = + | Keep_assigns + | Clear_assigns + | Label_assigns of Clabels.c_label + | Goal_assigns of assigns_kind ref + + ( --- Utilities --- ) + + let pp_vars fmt = function + | [] -> Format.pp_print_string fmt "-" + | x::xs -> + Format.fprintf fmt "@[<hov 2>%s" x.vname ; + List.iter + (fun x -> Format.fprintf fmt ",@,%s" x.vname) + xs ; + Format.fprintf fmt "@]" + + ( ------------------------------------------------------------------------ ) + ( --- Context Management --- ) + ( ------------------------------------------------------------------------ ) + + let close_property where context q = function + | Keep_opened -> + let bindings = D.pop where context in + { + bindings = bindings ; + property = q ; + } + | Close_context -> + { + bindings = D.closed ; + property = D.flush where context q ; + } + + exception Failed + + let on_context (pool,env) (where:string) + (akind,omega) closing assigns + (f : L.env -> assigns_kind -> F.pred -> F.pred) : t_prop + = + let context = D.push where pool omega.bindings in + try + let wp = ref F.p_false in + begin + try + let prop = + try f env akind omega.property + with Failed -> F.p_false + in + let huge = + let m = Wp_parameters.Huge.get () in + if m < 1 then 1 else if m > 29 then max_int else 1 lsl m + in + if F.huge_pred huge prop then + (raise(Wp_error.Error("WP","Huge property"))) ; + wp := prop ; + with err -> + let (source,reason) = Wp_error.protect err in + Datalib.Collector.add_warning ~source ~reason ~severe:true + "Abort goal generation" ; + end ; + ( f must be computed before, because of lazy bindings for assign goals ) + let asgns = + match assigns , akind with + | Goal_assigns gref , _ -> !gref + | Keep_assigns , a -> a + | Clear_assigns , _ | _ , NoAssigns -> NoAssigns + | Label_assigns l , EffectAssigns a when a.a_label = l -> + let ze = WpModel.dzone_empty () in + wp := D.subst a.a_effect ze (D.subst a.a_locals ze !wp) ; + NoAssigns + | Label_assigns _ , a -> a + in + asgns , close_property where context !wp closing + with err -> + D.kill where context ; + raise err + + let label env lab wp = + on_context env "label" wp Keep_opened (Label_assigns lab) + (fun env _assigns p -> + if lab = Clabels.Here then p else + match L.find_mem env lab with + | Some at -> + let here = L.mem_at env Clabels.Here in + let wp = WpModel.update ~at ~here p in + Clabels.label F.p_named lab wp + | None -> p) + + let tag t (akind,p) = (akind,{ p with property = F.p_named t p.property }) + + ( ------------------------------------------------------------------------ ) + ( --- Hypotheses and Goal Management --- ) + ( ------------------------------------------------------------------------ ) + + let merge_with f (a,p) (a',p') = + merge_assigns a a' , merge_property f p p' + + let add_hyp env h wp = + on_context env "add_hyp" wp Keep_opened Keep_assigns + (fun env _assigns p -> + if F.is_true p then p else + let hid, hp = h in + let pid = WpPropId.property_of_id hid in + match predicate env hp with + | Result h -> + Datalib.Collector.add_depend pid ; F.p_implies h p + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored hypothesis %a" Description.pp_property pid ; p) + + let add_goal env g wp = + on_context env "add_goal" wp Keep_opened Clear_assigns + (fun env _assigns p -> + if F.is_false p then p else + let pid, pn = g in + match predicate env pn with + | Result g -> + F.p_and g p + | Warning(source,reason) -> + Datalib.Collector.add_warning ~severe:true ~source ~reason + "Goal %a can not be translated" + Description.pp_property (WpPropId.property_of_id pid) ; + F.p_false) + + ( ------------------------------------------------------------------------ ) + ( --- Axiom Rule --- ) + ( ------------------------------------------------------------------------ ) + + let add_axiom _id name labels pn = + match + Wp_error.protect_translation3 L.add_axiom name labels pn + with + | Result () -> () + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored user-defined axiom '%s'" name + + ( ------------------------------------------------------------------------ ) + ( --- Initialisation Rule --- ) + ( ------------------------------------------------------------------------ ) + + exception SkipInit + + let compute_init_loc mem lv = + match addr mem lv with + | Warning(source,reason) -> + Datalib.Collector.add_warning + ~severe:false ~source ~reason + "No translation for init l-value '%a'" !Ast_printer.d_lval lv ; + raise SkipInit + | Result loc -> loc + + let compute_init_value mem vexp = + match expr mem vexp with + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored r-value of initializer" ; + raise SkipInit + | Result value -> value + + let init_value env lv typ e_opt wp = + on_context env "init_value" wp Keep_opened Keep_assigns + (fun env _assigns p -> + try + let mem = L.mem_at env Clabels.Here in + let obj = Ctypes.object_of typ in + let loc = compute_init_loc mem lv in + let loaded = WpModel.logic_of_value (WpModel.load mem obj loc) in + match e_opt with + | None -> + begin + match WpModel.symb_is_init obj with + | Some p_name -> F.p_implies (F.p_app1 p_name loaded) p + | None -> p + end + + | Some vexp -> + let value = + WpModel.logic_of_value (compute_init_value mem vexp) + in + F.p_implies (WpModel.equal obj loaded value) p + + with SkipInit -> p) + + let init_range env lv typ_elt ka kb wp = + on_context env "init_range" wp Keep_opened Keep_assigns + (fun env _assigns p -> + try + let mem = L.mem_at env Clabels.Here in + let obj = Ctypes.object_of typ_elt in + let loc = compute_init_loc mem lv in + let loaded = WpModel.logic_of_value (WpModel.load mem obj loc) in + match WpModel.symb_is_init_range obj with + | Some p_range -> + F.p_implies + (F.p_app3 p_range loaded (F.e_int64 ka) (F.e_int64 kb)) p + | None -> p + with SkipInit -> p) + + ( ------------------------------------------------------------------------ ) + ( --- Assignment Rule --- ) + ( ------------------------------------------------------------------------ ) + + let assign env lv e wp = + on_context env "assign" wp Keep_opened Keep_assigns + (fun env assigns p -> + let mem = L.mem_at env Clabels.Here in + match addr mem lv with + | Warning(source,reason) -> + Datalib.Collector.add_warning + ~severe:true ~source ~reason + "No translation for l-value '%a'" !Ast_printer.d_lval lv ; + F.p_false + | Result l -> + let te = Cil.typeOf e in + let obj = Ctypes.object_of te in + let wp = + match expr mem e with + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored r-value of assignment" ; + let modified = F.Aloc(obj,l) in + D.havoc_static (WpModel.subst_havoc mem modified) p + | Result v -> + let t = Ctypes.object_of (Cil.typeOf e) in + WpModel.subst_lval mem t l v p + in + begin + match assigns with + | NoAssigns -> wp + | EffectAssigns a -> + let zl = WpModel.dzone_assigned mem (F.Aloc(obj,l)) in + let zs = WpModel.dzone_union (F.var a.a_effect) zl in + D.subst a.a_effect zs wp + end ) + + ( ------------------------------------------------------------------------ ) + ( --- Return Rule --- ) + ( ------------------------------------------------------------------------ ) + + let return env e wp = + on_context env "return" wp Keep_opened Keep_assigns + (fun env _assigns p -> + match e with + | None -> p + | Some e -> + begin + let mem = L.mem_at env Clabels.Here in + match expr mem e with + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored returned value" ; + L.subst_result env None p + | Result v -> + let ty_to = L.result_type env in + let ty_from = Cil.typeOf e in + let r_cast = cast ty_to ty_from v in + begin + match r_cast with + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored returned value (because of a cast)" ; + L.subst_result env None p + | Result v -> L.subst_result env (Some v) p + end + end) + + ( ------------------------------------------------------------------------ ) + ( --- Conditional Rule --- ) + ( ------------------------------------------------------------------------ ) + + let test env e wpt wpf = + let pt = zip wpt in + let pf = zip wpf in + let wpe = merge_assigns (fst wpt) (fst wpf) , snd empty in + on_context env "test" wpe Keep_opened Keep_assigns + (fun env _assigns _true -> + match cond (L.mem_at env Clabels.Here) e with + | Result b -> + F.p_and + (F.p_named "Then" (F.p_implies b pt)) + (F.p_named "Else" (F.p_implies (F.p_not b) pf)) + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored condition of if-statement (%a)" !Ast_printer.d_exp e ; + F.p_and pt pf) + + ( ------------------------------------------------------------------------ ) + ( --- Switch Rule --- ) + ( ------------------------------------------------------------------------ ) + + let case_of_exp m_here e = + match Ctypes.get_int e with + | Some k -> F.e_int64 k + | None -> + match expr m_here e with + | Result( WpModel.V_int(_,term) ) -> term + | Result( _ ) -> + Datalib.Collector.add_warning + ~severe:true ~source:"wp" + ~reason:"non-integer expression" + "Can not translate switch statement@[@ (%a)@]" + !Ast_printer.d_exp e ; + raise Failed + | Warning(source,reason) -> + Datalib.Collector.add_warning + ~severe:true ~source ~reason + "Can not translate switch statement@[@ (%a)@]" + !Ast_printer.d_exp e ; + raise Failed + + let switch env e wp_cases wp_def = + let cases = List.map (fun (es,wp) -> es , zip wp) wp_cases in + let p_def = zip wp_def in + let assigns = + List.fold_left + (fun ak (_es,wp) -> merge_assigns ak (fst wp)) + (fst wp_def) wp_cases in + let wpe = assigns , { (snd empty) with property = p_def } in + on_context env "swith" wpe Keep_opened Keep_assigns + (fun env _assigns _true -> + + let m_here = L.mem_at env Clabels.Here in + let typ_e = Cil.typeOf e in + let int_e = case_of_exp m_here e in + let t = WpModel.tau_of_object (Ctypes.object_of typ_e) in + let var_e = D.fresh "k" (Formula.Acsl(t,Ctype typ_e)) in + let val_e = F.var var_e in + + let (default,cases) = + List.fold_left + (fun (default,cases) (es_case,p_case) -> + let ks = List.map (case_of_exp m_here) es_case in + let hs = F.p_disj (List.map (F.p_eq val_e) ks) in + let ds = F.p_conj (List.map (F.p_neq val_e) ks) in + F.p_and ds default , + F.p_and (F.p_implies hs p_case) cases + ) (F.p_true , F.p_true) cases + in + let wp_switch = F.p_and cases (F.p_implies default p_def) in + D.subst var_e int_e wp_switch) + + ( ------------------------------------------------------------------------ ) + ( --- Scope Rule --- ) + ( ------------------------------------------------------------------------ ) + + let scope env vars sc wp = + on_context env "scope" wp Keep_opened Keep_assigns + (fun env assigns p -> + let mem = L.mem_at env Clabels.Here in + let wp = WpModel.local_scope mem vars sc p in + begin + match assigns , sc with + | EffectAssigns a , (Mcfg.SC_Block_in | Mcfg.SC_Function_frame) -> + let zs = + List.fold_left + (fun zs x -> + let te = Ctypes.object_of x.vtype in + let ax = F.Aloc(te,WpModel.cvar mem x) in + let zx = WpModel.dzone_assigned mem ax in + WpModel.dzone_union zs zx) + (F.var a.a_locals) vars + in + D.subst a.a_locals zs wp + + | _ -> wp + end) + + ( ------------------------------------------------------------------------ ) + ( --- Build property to prove the FROMs --- ) + ( ------------------------------------------------------------------------ ) + + ( TODO: ask Lo�c if the parameters for [on_context] are correct + * because I don't really understand what it means... [2011-07-06-Anne]. ) + let build_prop_of_from wenv (pre:WpPropId.pred_info list) wp = + on_context wenv "build_froms" wp Keep_opened Keep_assigns + (fun env _assigns p -> + let alpha, p' = F.p_more_alpha_cv F.empty_alpha p in + let p = F.p_implies p p' in + let add_pre (alpha, p) (id, pre) = + let pid = WpPropId.property_of_id id in + match predicate env pre with + | Result pre -> + let pre = + match L.find_mem env Clabels.Pre with + | Some at -> + let here = L.mem_at env Clabels.Here in + WpModel.update ~at ~here pre + | None -> pre + in + Datalib.Collector.add_depend pid ; + let p = F.p_implies pre p in + let alpha', pre' = F.p_more_alpha_cv alpha pre in + let p = F.p_implies pre' p in + alpha', p + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Ignored hypothesis %a" Description.pp_property pid ; + alpha, p + in + let alpha, p = List.fold_left add_pre (alpha, p) pre in + let vars = F.fold_alpha (fun _v v' acc -> v'::acc) alpha [] in + let p = F.p_forall vars p in + let p = F.p_forall (L.collect_logic_vars env) p in + p + ) + + ( ------------------------------------------------------------------------ ) + ( --- Closing Goal --- ) + ( ------------------------------------------------------------------------ ) + + let close env wp = + on_context env "close" wp Close_context Clear_assigns + (fun env _assigns p -> + let pfinal = WpModel.quantify (L.mem_at env Clabels.Here) p in + let xs = F.freevars pfinal in + if xs <> [] then + (Datalib.Collector.add_warning + ~severe:false ~source:"CFG" + ~reason:"Some labels may escape the control flow" + "Generalization of un-labeled values" ; + F.p_forall xs pfinal) + else pfinal) + + ( ------------------------------------------------------------------------ ) + ( --- Normal Assigns clauses --- ) + ( ------------------------------------------------------------------------ ) + + let rec translate_assigned_targets env assigned = + match assigned with + | [] -> Result [] + | lv::others -> + match translate_assigned_targets env others with + | Warning(p,m) -> Warning(p,m) + | Result acc -> + Wp_error.protect_translation + (fun e t -> L.assigned e t @ acc) + env lv + + let translate_assigned env assigned = + let lvset = List.fold_left + (fun lvset (loc,_from) -> + Cil_datatype.Term.Set.add loc.it_content lvset) + Cil_datatype.Term.Set.empty assigned + in + translate_assigned_targets env (Cil_datatype.Term.Set.elements lvset) + + type assigned = A_everything | A_region of WpModel.loc F.assigned list + + let assigned_of_assigns env assigned = + match assigned with + | WritesAny -> A_everything + | Writes assigned -> + match translate_assigned env assigned with + | Result region -> A_region region + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Can not translate assign hypothesis, assigns everything instead" ; + A_everything + + ( Region for proving assign close ) + let assigned_for_assigns_goal kind label_from env assigned = + let env_assigned = + match kind with + | WpPropId.StmtAssigns -> L.env_at env label_from + | WpPropId.LoopAssigns -> env + in + match translate_assigned env_assigned assigned with + | Warning(wsrc, msg) -> raise (Wp_error.Error(wsrc,msg)) + | Result region -> region + + ( Apply region during wp ) + let havoc_region hkind caller_mem region prop = + match region with + | A_everything -> + WpModel.quantify caller_mem prop + | A_region region -> + let hs = + List.concat + (List.map (WpModel.subst_havoc caller_mem) region) in + begin + match hkind with + | WpPropId.StmtAssigns -> D.havoc_static hs prop + | WpPropId.LoopAssigns -> D.havoc_inductive hs prop + end + + ( ------------------------------------------------------------------------ ) + ( --- Assigns Method --- ) + ( ------------------------------------------------------------------------ ) + + let assigns_method () = + let mth = Wp_parameters.get_assigns_method () in + match mth with + | Mcfg.NoAssigns -> mth + | Mcfg.EffectAssigns when WpModel.effect_supported -> mth + | _ -> + if WpModel.assigns_supported + then Mcfg.NormalAssigns + else Mcfg.NoAssigns + + ( ------------------------------------------------------------------------ ) + ( --- Generate Observational Assigns Goal --- ) + ( ------------------------------------------------------------------------ ) + + let add_normal_assigns env pid label kind assigned wp = + on_context env "add_assigns" wp Keep_opened Clear_assigns + (fun env _noassigns prop -> + try + let label_from = Clabels.c_label label in + let mem1 = L.mem_at env label_from in + let mem2 = L.mem_at env Clabels.Here in + let region = assigned_for_assigns_goal kind label_from env assigned in + let goal = WpModel.assigns_goal mem1 region mem2 in + F.p_and goal prop + with e -> ( [VP 2011-02-03] Argl! ) + let (source,reason) = Wp_error.protect e in + Datalib.Collector.add_warning + ~severe:true ~source ~reason + "Goal for %a can not be translated" + WpPropId.pretty pid ; + F.p_false) + + ( ------------------------------------------------------------------------ ) + ( --- Prove assigns clauses with WpModel.dzones --- ) + ( ------------------------------------------------------------------------ ) + + let add_effect_assigns env pid label kind assigned wp = + let from = Clabels.c_label label in + let goal = ref NoAssigns in + on_context env "add_assigns" wp Keep_opened (Goal_assigns goal) + (fun env _noassigns _prop -> + try + let asgns = assigned_for_assigns_goal kind from env assigned in + let ze = D.fresh "ze" (Formula.Model WpModel.tau_of_dzone) in + let zx = D.fresh "zx" (Formula.Model WpModel.tau_of_dzone) in + let mem = L.mem_at env from in + let zs = List.fold_left + (fun zs a -> + let zx = WpModel.dzone_assigned mem a in + WpModel.dzone_union zs zx) + (F.var zx) asgns + in + goal := EffectAssigns { + a_pid = pid ; + a_label = from ; + a_effect = ze ; + a_locals = zx ; + } ; + WpModel.dzone_subset (F.var ze) zs + with e -> ( [VP 2011-02-03] Argl! ) + let (source,reason) = Wp_error.protect e in + Datalib.Collector.add_warning + ~severe:true ~source ~reason + "Goal for %a can not be translated" + WpPropId.pretty pid ; + F.p_false) + + ( ------------------------------------------------------------------------ ) + ( --- Dispatch Assigns Goal against selected method --- ) + ( ------------------------------------------------------------------------ ) + + let add_assigns env assigns wp = + let pid, a_desc = assigns in + let label = a_desc.WpPropId.a_label in + let kind = a_desc.WpPropId.a_kind in + let assigned = a_desc.WpPropId.a_assigns in + match assigned with + WritesAny -> + on_context env "add_assigns" wp Keep_opened + (Goal_assigns (ref NoAssigns)) + (fun _ _ _ -> F.p_true) ( Nothing to prove ) + | Writes assigns -> + match assigns_method () with + | Mcfg.NoAssigns -> + Wp_parameters.abort "Unsupported assigns with the model" + | Mcfg.NormalAssigns -> + add_normal_assigns env pid label kind assigns wp + | Mcfg.EffectAssigns -> + add_effect_assigns env pid label kind assigns wp + + ( Assigns Hypothesis ) + + let check_assigns m goal region wp = + match goal , region with + | NoAssigns , _ -> wp + | (EffectAssigns _ ) , A_everything -> + Datalib.Collector.add_warning + ~severe:true + ~reason:"Assigns everything during calculus" + "Can not prove the assign goal" ; + F.p_false + | EffectAssigns a , A_region zones -> + let ze = List.fold_left + (fun zs a -> + let za = WpModel.dzone_assigned m a in + WpModel.dzone_union zs za) + (F.var a.a_effect) zones + in + D.subst a.a_effect ze wp + + let use_assigns env hid a_desc wp = + on_context env "use_assigns" wp Close_context Keep_assigns + (fun env assignsgoal p -> + let kind = a_desc.WpPropId.a_kind in + let assigned = a_desc.WpPropId.a_assigns in + (match hid with + | Some h -> Datalib.Collector.add_depend (WpPropId.property_of_id h) + | None -> ()) ; + let region = assigned_of_assigns env assigned in + let mem = L.mem_at env Clabels.Here in + let p0 = check_assigns mem assignsgoal region p in + havoc_region kind mem region p0) + + ( -------------------------------------------------------------------------- ) + ( --- CALL NEW API --- ) + ( -------------------------------------------------------------------------- ) + + type callenv = { + callsite : Clabels.c_label ; ( Clabels.CallAt stmt ) + m_pre : WpModel.mem ; + m_post : WpModel.mem ; + v_args : WpModel.value list ; + } + + ( Local elements used in call_xxx ) + let callenv env stmt args = + let pre_label = Clabels.CallAt stmt.sid in + let m_pre = L.mem_at env pre_label in + let m_post = L.mem_at env Clabels.Here in + let translate_arg e = + match expr m_pre e with + | Warning(source,reason) -> + Datalib.Collector.add_warning ~source ~reason + "Can not call function, no translation for parameter '%a'" + !Ast_printer.d_exp e ; + raise Failed + | Result v -> v + in { + callsite = pre_label ; + m_pre = m_pre ; + m_post = m_post ; + v_args = List.map translate_arg args ; + } + + ( Utility function to handle errors in call_xxx ) + let do_prop env item p = + match predicate env p with + | Warning(source,reason) -> + Datalib.Collector.add_warning + ~source ~reason + "Ignored %s for function call" item ; + F.p_true + | Result p -> p + + let do_properties env item idps = + F.p_conj (List.map (fun (_id,p) -> do_prop env item p) idps) + + let rec do_hypothesis env item idps wp = + match idps with + | [] -> wp + | (_id,h)::hs -> F.p_implies (do_prop env item h) (do_hypothesis env item hs wp) + + ( Apply a returned value from a function call ) + let do_return call kf lvopt p_after = + let t_result = Kernel_function.get_return_type kf in + if Ctypes.is_void t_result then + ( p_after , None ) + else + let x_result = D.fresh "result" + (Formula.Acsl ((WpModel.tau_of_object (Ctypes.object_of t_result)), + Ctype t_result)) in + match lvopt with + | None -> p_after , Some x_result + | Some lv -> + let lv_t = Ctypes.object_of t_result in + let casted_result = + cast t_result (Cil.typeOfLval lv) + (WpModel.value_of_logic lv_t (F.var x_result)) + in + let v_result = match casted_result with + | Warning(source,reason) -> + Datalib.Collector.add_warning + ~severe:true ~source ~reason + "Can not cast the returned value" ; + raise Failed + | Result res -> res + in + + let p_with_result = + begin + ( TODO : check memory for computing return loc ) + match addr call.m_post lv with + | Warning(source, reason) -> + Datalib.Collector.add_warning + ~severe:true ~source ~reason + "Can not assign the returned value, no translation for l-value" ; + raise Failed + | Result loc -> + WpModel.subst_lval call.m_post lv_t loc v_result p_after + end + in + p_with_result , Some x_result + + ( ------------------------------------------------------------------------ ) + ( --- CALL Rule --- ) + ( ------------------------------------------------------------------------ ) + + let call_goal_precond caller_env stmt kf args ~pre wp = + on_context caller_env "call_goal_precond" wp Keep_opened Keep_assigns + (fun env _assigns p -> + let call = callenv env stmt args in + let env_pre = L.call_pre env kf call.v_args call.m_pre in + let preconds = do_properties env_pre "pre-condition" pre in + F.p_and preconds p) + + let add_dependencies = List.iter Datalib.Collector.add_depend + + let call_normal_only caller_env stmt lv kf args ~pre ~post ~assigns ~p_post = + on_context caller_env "call_normal" p_post Keep_opened Keep_assigns + (fun env assigns_method p_post -> + add_dependencies (WpAnnot.get_called_assigns kf) ; + add_dependencies (WpAnnot.get_called_post_conditions kf) ; + add_dependencies (WpAnnot.get_called_preconditions_at kf stmt) ; + let call = callenv env stmt args in + let p_after , x_result = do_return call kf lv p_post in + let env_pre = L.call_pre env kf call.v_args call.m_pre in + let env_post = L.call_post env kf call.v_args call.m_pre call.m_post x_result in + let p_called = do_hypothesis env_post "post-condition" post p_after in + let p_called = match x_result with + | None -> p_called + | Some x -> D.forall [x] p_called + in + let asgnd = assigned_of_assigns env_pre assigns in + let p_havoc = havoc_region WpPropId.StmtAssigns call.m_post asgnd p_called in + let p_before = do_hypothesis env_pre "pre-condition" pre p_havoc in + check_assigns call.m_pre assigns_method asgnd p_before) + + let call_exit_only caller_env stmt kf args ~pre ~pexit ~assigns ~p_exit = + on_context caller_env "call_normal" p_exit Keep_opened Keep_assigns + (fun env assigns_method p_exit -> + add_dependencies (WpAnnot.get_called_assigns kf) ; + add_dependencies (WpAnnot.get_called_exit_conditions kf) ; + add_dependencies (WpAnnot.get_called_preconditions_at kf stmt) ; + let call = callenv env stmt args in + let x_status = L.exit_status env in + let env_pre = L.call_pre env kf call.v_args call.m_pre in + let env_exit = L.call_exit env kf call.v_args call.m_pre call.m_post x_status in + let p_called = do_hypothesis env_exit "exit-condition" pexit p_exit in + let p_called = D.forall [x_status] p_called in + let asgnd = assigned_of_assigns env_pre assigns in + let p_havoc = havoc_region WpPropId.StmtAssigns call.m_post asgnd p_called in + let p_before = do_hypothesis env_pre "pre-condition" pre p_havoc in + check_assigns call.m_pre assigns_method asgnd p_before) + + let call caller_env stmt lv kf args ~pre ~post ~pexit ~assigns ~p_post ~p_exit = + let wp_post = + if is_empty p_post then p_post + else call_normal_only caller_env stmt lv kf args ~pre ~post ~assigns ~p_post + in + let wp_exit = + if is_empty p_exit then p_exit + else call_exit_only caller_env stmt kf args ~pre ~pexit ~assigns ~p_exit + in + merge wp_post wp_exit + +( --- End of Weakest Precondition Rules --- *) + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/cfgWeakestPrecondition.mli frama-c-20111001+nitrogen+dfsg/src/wp/cfgWeakestPrecondition.mli --- frama-c-20110201+carbon+dfsg/src/wp/cfgWeakestPrecondition.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/cfgWeakestPrecondition.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,33 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** {1 VC Generator} ) +( -------------------------------------------------------------------------- *) + +module Create + (WpModel:sig include Mwp.S val model: string end) + : +sig + include Mcfg.S + val zip : t_prop -> WpModel.F.pred +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/cil2cfg.ml frama-c-20111001+nitrogen+dfsg/src/wp/cil2cfg.ml --- frama-c-20110201+carbon+dfsg/src/wp/cil2cfg.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/cil2cfg.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,1330 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**********************************************************************) + +( Build a CFG of a function keeping some information of the initial structure. + ) + +open Cil_types + +let dkey = "cil2cfg" (* debugging key ) +let debug fmt = Wp_parameters.debug ~dkey fmt +let debug2 fmt = Wp_parameters.debug ~dkey ~level:2 fmt + +() +( {2 Nodes} ) + +(** Be careful that only Bstmt are real Block statements ) +type block_type = + Bstmt of stmt | Bthen of stmt | Belse of stmt | Bloop of stmt | Bfct + ( added to identify 2 blocks for tests, else there are mixed up because same + * sid ) + +type node_type = + | Vstart | Vend | Vexit + | VfctIn | VfctOut ( TODO : not useful anymore -> Bfct ) + | VblkIn of block_type block + | VblkOut of block_type * block + | Vstmt of stmt + | Vcall of stmt * lval option * exp * exp list + | Vtest of bool * stmt * exp (** bool=true for In and false for Out ) + | Vswitch of stmt exp + | Vloop of bool option * stmt + (** boolean is is_natural. None means the node has not been detected + * as a loop ) + | Vloop2 of bool int + +type node_info = { kind : node_type ; mutable reachable : bool } + +type node = node_info ref + +let node_type n = !n.kind + +let bkind_stmt bk = match bk with + | Bfct -> None + | Bstmt s | Bthen s | Belse s | Bloop s -> Some s + +let bkind_sid bk = match bk with + | Bfct -> 0 + | Bstmt s | Bthen s | Belse s | Bloop s -> s.sid + +type node_id = int * int + +(** gives a identifier to each CFG node in order to hash them *) +let node_type_id t = match t with + | Vstart -> (0, 0) + | VfctIn -> (0, 1) + | VfctOut -> (0, 2) + | Vexit -> (0, 3) + | Vend -> (0, 4) + | Vstmt s | Vtest (true, s, _) | Vswitch (s,_) | Vcall (s, _, _, _) -> + (1, s.sid) + | Vloop (_, s) -> (2, s.sid) + | Vloop2 (_, n) -> (3, n) + | VblkIn (Bfct, _) -> (4, 0) + | VblkIn (Bstmt s,_) -> (5, s.sid) + | VblkIn (Bthen s,_) -> (6, s.sid) + | VblkIn (Belse s,_) -> (7, s.sid) + | VblkIn (Bloop s,_) -> (8, s.sid) + | VblkOut (Bfct, _) -> (9, 0) + | VblkOut (Bstmt s,_) -> (10, s.sid) + | VblkOut (Bthen s,_) -> (11, s.sid) + | VblkOut (Belse s,_) -> (12, s.sid) + | VblkOut (Bloop s,_) -> (13, s.sid) + | Vtest (false, s, _) -> (14, s.sid) + +let node_id n = node_type_id (node_type n) + +let pp_bkind fmt bk = match bk with + | Bfct -> Format.fprintf fmt "fct" + | Bstmt s -> Format.fprintf fmt "stmt:%d" s.sid + | Bthen s -> Format.fprintf fmt "then:%d" s.sid + | Belse s -> Format.fprintf fmt "else:%d" s.sid + | Bloop s -> Format.fprintf fmt "loop:%d" s.sid + +let pp_node_type fmt n = match n with + | Vstart -> Format.fprintf fmt "<start>" + | VfctIn -> Format.fprintf fmt "<fctIn>" + | VfctOut -> Format.fprintf fmt "<fctOut>" + | Vend -> Format.fprintf fmt "<end>" + | Vexit -> Format.fprintf fmt "<exit>" + | VblkIn (bk,_) -> Format.fprintf fmt "<blkIn-%a>" pp_bkind bk + | VblkOut (bk,_) -> Format.fprintf fmt "<blkOut-%a>" pp_bkind bk + | Vcall (s, _, _, _) -> Format.fprintf fmt "<callIn-%d>" s.sid + | Vstmt s -> Format.fprintf fmt "<stmt-%d>" s.sid + | Vtest (b, s, _) -> + Format.fprintf fmt "<test%s-%d>" (if b then "In" else "Out") s.sid + | Vswitch (s,_) -> Format.fprintf fmt "<switch-%d>" s.sid + | Vloop (_, s) -> Format.fprintf fmt "<loop-%d>" s.sid + | Vloop2 (_, n) -> Format.fprintf fmt "<loop-n%d>" n + +let same_node v v' = + (node_id v) = (node_id v') + +(** the CFG nodes ) +module VL = struct + type t = node + + let hash v = let k = node_type v in Hashtbl.hash (node_type_id k) + + let equal v v' = same_node v v' + + let compare v v' = + let k = node_type v in + let k' = node_type v' in + Extlib.compare_basic (node_type_id k) (node_type_id k') + + let pretty fmt v = pp_node_type fmt (node_type v) +end + +let pp_node fmt v = VL.pretty fmt v + +let start_stmt_of_node v = match node_type v with + | Vstart | Vtest (false, _, _) | VblkOut _ + | VfctIn | VfctOut | Vend | Vexit | Vloop2 _ -> None + | VblkIn (bk, _) -> bkind_stmt bk + | Vstmt s | Vtest (true, s, _) | Vloop (_, s) | Vswitch (s,_) + | Vcall (s, _, _, _) + -> Some s + +let node_stmt_opt v = match node_type v with + | Vstart | Vtest (false, _, _) + | VfctIn | VfctOut | Vend | Vexit | Vloop2 _ -> None + | VblkIn (bk, _) | VblkOut (bk, _) -> bkind_stmt bk + | Vstmt s | Vtest (true, s, _) | Vloop (_, s) | Vswitch (s,_) + | Vcall (s, _, _, _) + -> Some s + +let node_stmt_exn v = + match node_stmt_opt v with None -> raise Not_found | Some s -> s + +() +( {2 Edge labels} ) + +type edge_type = + | Enone (** normal edge *) + | Ethen (** then branch : edge source is a Vtest *) + | Eelse (** else branch : edge source is a Vtest *) + | Eback (** back edge to a loop : the edge destination is a Vloop *) + | EbackThen (** Eback + Ethen *) + | EbackElse (** Eback + Eelse *) + | Ecase of (exp list) (** switch branch : edge source is a Vswitch. + Ecase [] for default case *) + | Enext (** not really a edge : gives the next node of a complex stmt *) + +(** the CFG edges ) +module EL = struct + + let compare_edge_type e1 e2 = + if e1 == e2 then 0 + else match e1, e2 with + | Enone, Enone | Ethen, Ethen | Eelse, Eelse | Eback, Eback + | EbackThen, EbackThen | EbackElse, EbackElse | Enext, Enext -> 0 + + | Ecase l1, Ecase l2 -> Extlib.list_compare Cil_datatype.Exp.compare l1 l2 + + | Enone, (Ethen | Eelse | Eback | EbackThen | EbackElse | Ecase _ | Enext) + | Ethen, (Eelse | Eback | EbackThen | EbackElse | Ecase _ | Enext) + | Eelse, (Eback | EbackThen | EbackElse | Ecase _ | Enext) + | Eback, (EbackThen | EbackElse | Ecase _ | Enext) + | EbackThen, (EbackElse | Ecase _ | Enext) + | EbackElse, (Ecase _ | Enext) + | Ecase _, Enext + -> -1 + + | Enext, (Ecase _ | EbackElse | EbackThen | Eback | Eelse | Ethen | Enone) + | Ecase _, (EbackElse | EbackThen | Eback | Eelse | Ethen | Enone) + | EbackElse, (EbackThen | Eback | Eelse | Ethen | Enone) + | EbackThen, (Eback | Eelse | Ethen | Enone) + | Eback, (Eelse | Ethen | Enone) + | Eelse, (Ethen | Enone) + | Ethen, Enone -> 1 + + type t = edge_type ref + + let compare (e1 : t) (e2 : t) = compare_edge_type !e1 !e2 + let default = ref Enone + let pretty fmt e = + let txt = match e with + | Enone -> "----" | Ethen -> "then" | Eelse -> "else" + | Eback -> "back" | EbackThen -> "then-back" | EbackElse -> "else-back" + | Ecase [] -> "default" + | Ecase l -> Pretty_utils.sfprintf "case(%a)" + (Pretty_utils.pp_list ~sep:", " !Ast_printer.d_exp) l + | Enext -> "(next)" + in Format.fprintf fmt "%s" txt +end + +() +( {2 Graph} ) + +(** the CFG is an ocamlgraph, but be careful to use it through the cfg function + * because some edges doesn't have the same meaning the some others... *) +module CFG = Graph.Imperative.Digraph.ConcreteLabeled(VL)(EL) + +(** Set of edges. *) +module Eset = Set.Make (CFG.E) + +(** Set of nodes. *) +module Nset = Set.Make (CFG.V) + +(** The final CFG is composed of the graph, but also : + * the function that it represents, + * an hashtable to find a CFG node knowing its hashcode, + * and the hashcode of the start node ) +type t = { + kernel_function : kernel_function; + graph : CFG.t; + spec_only : bool; + stmt_node : ((intint), CFG.V.t) Hashtbl.t; + start_id : int; + unreachables : node_type list; + loop_nodes : (node list) option; + mutable loop_cpt : int; +} + +let new_cfg_env spec_only kf = { + kernel_function = kf; + spec_only = spec_only ; + graph = CFG.create (); + stmt_node = Hashtbl.create 97; + start_id = Cil.Sid.next (); + unreachables = []; + loop_nodes = None; + loop_cpt = 0; +} + +let cfg_kf cfg = cfg.kernel_function +let cfg_graph cfg = cfg.graph +let cfg_spec_only cfg = cfg.spec_only + +let unreachable_nodes cfg = cfg.unreachables + +() +( {2 CFG edges} ) + +type edge = CFG.E.t + +let edge_type e = !(CFG.E.label e) +let edge_src e = CFG.E.src e +let edge_dst e = CFG.E.dst e + +let pp_edge fmt e = + Format.fprintf fmt "%a -%a-> %a" + pp_node (CFG.E.src e) EL.pretty (edge_type e) pp_node (CFG.E.dst e) + +let pred_e cfg n = + try + let edges = CFG.pred_e cfg.graph n in + List.filter (fun e -> (edge_type e) <> Enext) edges + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.pred_e] pb with node %a" pp_node n; []) + +let succ_e cfg n = + try + let edges = CFG.succ_e cfg.graph n in + List.filter (fun e -> (edge_type e) <> Enext) edges + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.succ_e] pb with node %a" pp_node n; []) + + +let is_back_edge e = match (edge_type e) with + | Eback | EbackThen | EbackElse -> true + | Enone | Ethen | Eelse | Ecase _ | Enext -> false + +let edge_key e = (VL.hash (edge_src e)), (VL.hash (edge_dst e)) + +let same_edge e1 e2 = (edge_key e1 = edge_key e2) + +() +( {2 Iterators} ignoring the [Enext] edges ) + +let iter_nodes f cfg = CFG.iter_vertex f (cfg.graph) +let fold_nodes f cfg acc = CFG.fold_vertex f (cfg.graph) acc + +let iter_edges f cfg = + let f e = match (edge_type e) with Enext -> () | _ -> f e in + CFG.iter_edges_e f (cfg.graph) + +let iter_succ f cfg n = + let f e = + match (edge_type e) with Enext -> () | _ -> f (CFG.E.dst e) + in try CFG.iter_succ_e f (cfg.graph) n + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.iter_succ] pb with node %a" pp_node n) + +let fold_succ f cfg n acc = + let f e acc = + match (edge_type e) with Enext -> acc | _ -> f (CFG.E.dst e) acc + in try CFG.fold_succ_e f (cfg.graph) n acc + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.fold_succ] pb with node %a" pp_node n; acc) + +let fold_pred f cfg n acc = + let f e acc = + match (edge_type e) with Enext -> acc | _ -> f (CFG.E.src e) acc + in try CFG.fold_pred_e f (cfg.graph) n acc + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.fold_pred] pb with node %a" pp_node n; acc) + +let iter_succ_e f cfg n = + let f e = + match (edge_type e) with Enext -> () | _ -> f e + in try CFG.iter_succ_e f (cfg.graph) n + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.iter_succ_e] pb with node %a" pp_node n) + +let iter_pred_e f cfg n = + let f e = + match (edge_type e) with Enext -> () | _ -> f e + in try CFG.iter_pred_e f (cfg.graph) n + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.iter_pred_e] pb with node %a" pp_node n) + +let fold_pred_e f cfg n acc = + let f e acc = + match (edge_type e) with Enext -> acc | _ -> f e acc + in try CFG.fold_pred_e f (cfg.graph) n acc + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.fold_pred_e] pb with node %a" pp_node n; acc) + +let fold_succ_e f cfg n acc = + let f e acc = + match (edge_type e) with Enext -> acc | _ -> f e acc + in try CFG.fold_succ_e f (cfg.graph) n acc + with Invalid_argument _ -> + (Wp_parameters.warning "[cfg.fold_succ_e] pb with node %a" pp_node n; acc) + + +() +( {2 Getting information} *) + +let cfg_start cfg = Hashtbl.find cfg.stmt_node (node_type_id Vstart) + +let start_edge cfg = match succ_e cfg (cfg_start cfg) with [e] -> e + | _ -> Wp_parameters.fatal "[cfg] should have exactly ONE starting edge !" + +exception Found of node +let find_stmt_node cfg stmt = + let find n = match node_stmt_opt n with None -> () + | Some s -> if s.sid = stmt.sid then raise (Found n) + in + try (iter_nodes find cfg; raise Not_found) + with Found n -> n + +(** Get the edges going out a test node with the then branch first ) +let get_test_edges cfg v = + match succ_e cfg v with + | [e1; e2] -> + begin match (edge_type e1), (edge_type e2) with + | (Ethen|EbackThen), (Eelse|EbackElse) -> e1, e2 + | (Eelse|EbackElse), (Ethen|EbackThen) -> e2, e1 + | _, (Eelse|EbackElse) -> + Wp_parameters.fatal "[cfg] test node with invalid edges %a" + pp_edge e1 + | _, _ -> + Wp_parameters.fatal "[cfg] test node with invalid edges %a" + pp_edge e2 + end + | _ -> raise (Invalid_argument "[cfg:get_test_edges] not a test") + +let get_switch_edges cfg v = + match node_type v with + | Vswitch _ -> + begin + let get_case (cl, dl) e = match (edge_type e) with + | Ecase [] -> cl, e::dl + | Ecase c -> (c, e)::cl, dl + | _ -> Wp_parameters.fatal ("[cfg] switch node with invalid edges") + in match List.fold_left get_case ([],[]) (succ_e cfg v) with + | cl, [d] -> cl, d + | _ -> + Wp_parameters.fatal ("[cfg] switch node with several 'default' ?") + end + | _ -> raise (Invalid_argument "[cfg:get_switch_edges] not a switch") + +let get_call_out_edges cfg v = + let e1, e2 = match succ_e cfg v with + | [e1;e2] -> e1, e2 + | _ -> assert false + in + let en, ee = match node_type (edge_dst e1) , + node_type (edge_dst e2) with + | _, Vexit -> e1, e2 + | Vexit, _ -> e2, e1 + | _, _ -> assert false + in en, ee + +let get_edge_labels e = + let v_after = edge_dst e in + let l = match node_type v_after with + | Vstart -> assert false + | VfctIn -> [] + | Vexit | VfctOut -> [Clabels.Post] + | VblkIn (Bstmt s, _) -> [Clabels.mk_stmt_label s] + | Vtest (false, _, _) | VblkIn _ | VblkOut _ | Vend -> [] + | Vcall (s,_,_,_) -> + [Clabels.CallAt s.sid; Clabels.mk_stmt_label s] + | Vstmt s | Vtest (true, s, _) | Vswitch (s,_) -> + [Clabels.mk_stmt_label s] + | Vloop2 _ -> [] + | Vloop (_,s) -> + if is_back_edge e then [] + else [Clabels.mk_stmt_label s] + in + let v_before = edge_src e in + match node_type v_before with + | VfctIn -> Clabels.Pre::l + | Vloop (_, s) -> (Clabels.mk_loop_label s)::l + | _ -> l + +let next_edge cfg n = + let edges = match node_type n with + | VblkIn _ | Vswitch _ | Vtest _ | Vloop _ -> + let edges = CFG.succ_e cfg.graph n in + List.filter (fun e -> (edge_type e) = Enext) edges + | Vcall _ -> + let en, _ee = get_call_out_edges cfg n in [en] + | Vstmt _ -> + let edges = match CFG.succ_e cfg.graph n with + | (([] | _::[]) as edges) -> edges + | edges -> ( this case may happen in case of a loop + which is not really a loop : it is then a Vstmt, + and the Enext is not the succ_e. ) + List.filter (fun e -> (edge_type e) = Enext) edges + in edges + | _ -> + debug "[next_edge] not found for %a@." pp_node n; + raise Not_found ( No Enext information on this node ) + in + match edges with + | [] -> ( can append when nodes have been removed *) raise Not_found + | [e] -> e + | _ -> Wp_parameters.fatal "several (%d) Enext edges to node %a" + (List.length edges) pp_node n + +(** Find the node that follows the input node statement. +* The statement postcondition can then be stored to the edges before that node. +* @raise Not_found when the node after has been removed (unreachable) ) +let node_after cfg n = edge_dst (next_edge cfg n) + +let get_pre_edges cfg n = pred_e cfg n + +let get_post_edges cfg v = + try let v' = node_after cfg v in pred_e cfg v' + with Not_found -> [] + +let get_exit_edges cfg src = + debug "[get_exit_edges] of %a@." pp_node src; + let do_node n acc = + let add_exit e acc = + let dst = edge_dst e in + match node_type dst with + | Vexit -> + debug + "[get_exit_edges] add %a@." pp_edge e; + ( (succ_e cfg dst) @ acc ) + e :: acc + | _ -> acc + in fold_succ_e add_exit cfg n acc + in + let rec do_node_and_preds n acc = + let acc = do_node n acc in + if CFG.V.compare src n = 0 then acc + else do_preds n acc + and do_preds n acc = + fold_pred do_node_and_preds cfg n acc + in + let edges = try do_preds (node_after cfg src) [] with Not_found -> [] in + if edges = [] then + debug "[get_exit_edges] -> empty"; + edges + +let add_edges_before cfg src set e_after = + let rec add_preds set e = + let e_src = edge_src e in + if CFG.V.compare src e_src = 0 then set + else + let add_edge_and_preds e set = + if Eset.mem e set then set + else add_preds (Eset.add e set) e + in fold_pred_e add_edge_and_preds cfg e_src set + in add_preds set e_after + +let get_internal_edges cfg n = + let edges = try pred_e cfg (node_after cfg n) with Not_found -> [] in + let set = Eset.empty in + let set = List.fold_left (add_edges_before cfg n) set edges in + edges, set + +let rec get_edge_next_stmt cfg e = + let v_after = edge_dst e in + let get_next v = match succ_e cfg v with + | [e] -> get_edge_next_stmt cfg e + | [] | _ :: _ -> None ( nodes without statement should have one succ, + except the last one ) + in + match node_type v_after with + | VblkOut _ | VblkIn ((Bthen _|Belse _|Bloop _|Bfct),_) -> get_next v_after + | _ -> + match node_stmt_opt v_after with + | Some s -> Some s + | None -> get_next v_after + +let get_post_logic_label cfg v = + match get_post_edges cfg v with [] -> None + | e::_ -> ( TODO: is this ok to consider only one edge ? ) + match get_edge_next_stmt cfg e with + | None -> None + | Some s -> Some (Clabels.mk_logic_label s) + +let blocks_closed_by_edge cfg e = + let v_before = edge_src e in + let blocks = match node_type v_before with + | Vstmt s | Vtest (true, s, _) | Vloop (_, s) | Vswitch (s,_) -> + Cfg.clearFileCFG ~clear_id:false (Ast.get ()); + Cfg.computeFileCFG (Ast.get ()); + + begin match s.succs with + | [s'] -> Kernel_function.blocks_closed_by_edge s s' + | [] | _ :: _ -> + let s' = get_edge_next_stmt cfg e in + match s' with + | None -> [] + | Some s' -> + debug + "[blocks_closed_by_edge] found sid:%d -> sid:%d@." + s.sid s'.sid; + Kernel_function.blocks_closed_by_edge s s' + end + | _ -> ( TODO ? ) [] + in + let v_after = edge_dst e in + let blocks = match node_type v_after with + | VblkOut (Bfct, b) -> b::blocks + | _ -> blocks + in blocks + +let has_exit cfg = + try + let node = Hashtbl.find cfg.stmt_node (node_type_id Vexit) in + match pred_e cfg node with + | [] -> false + | _ -> true + with Not_found | Invalid_argument _ -> false + +(~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) +(** {2 Generic table to store things on edges} ) + +module type HEsig = sig + type ti + type t + val create : int -> t + val find : t -> edge -> ti + val find_all : t -> edge -> ti list + val add : t -> edge -> ti -> unit + val replace : t -> edge -> ti -> unit + val remove : t -> edge -> unit + val clear : t -> unit +end + +module HE (I : sig type t end) = struct + type ti = I.t + type t = ((intint), ti) Hashtbl.t + let create n = Hashtbl.create n + let edge_key e = (VL.hash (edge_src e)), (VL.hash (edge_dst e)) + let find info e = Hashtbl.find info (edge_key e) + let find_all info e = Hashtbl.find_all info (edge_key e) + let add info e i = Hashtbl.add info (edge_key e) i + let replace info e i = Hashtbl.replace info (edge_key e) i + let remove info e = Hashtbl.remove info (edge_key e) + let clear info = Hashtbl.clear info +end + +() +( {2 Building the CFG} *) + +let add_node env t = + let id = node_type_id t in + let n = {kind = t ; reachable = false } in + debug "add node : %a@." VL.pretty (ref n); + let n = CFG.V.create (ref n) in + Hashtbl.add env.stmt_node id n; + n + +let add_edge env n1 edge_type n2 = + let e = CFG.E.create n1 (ref edge_type) n2 in + debug "add edge : %a@." pp_edge e; + CFG.add_edge_e env.graph e + +let remove_edge env e = + debug "remove edge : %a@." pp_edge e; + CFG.remove_edge_e env.graph e + +let insert_loop_node env loop_head loop_kind = + let n_loop = add_node env loop_kind in + let mv_pred_edge e = + add_edge env (edge_src e) (edge_type e) n_loop; + remove_edge env e + in iter_pred_e mv_pred_edge env loop_head; + add_edge env n_loop Enone loop_head; + n_loop + +let init_cfg spec_only kf = + let env = new_cfg_env spec_only kf in + let start = add_node env (Vstart) in + let fct_in = add_node env (VfctIn) in + let _ = add_edge env start Enone fct_in in + let fct_out = add_node env (VfctOut) in + let nexit = add_node env (Vexit) in + let nend = add_node env (Vend) in + let _ = add_edge env fct_out Enone nend in + let _ = add_edge env nexit Enone nend in + env, fct_in, fct_out + +let get_node env t = + let id = node_type_id t in + debug "get_node: %a --> id:%d,%d" + pp_node_type t (fst id) (snd id); + try Hashtbl.find env.stmt_node id + with Not_found -> add_node env t + +(** In some cases (goto for instance) we have to create a node before having +* processed if through [cfg_stmt]. It is important that the created node +* is the same than while the 'normal' processing ! That is why +* this pattern matching might seem redondant with the other one. *) +let get_stmt_node env s = match s.skind with + | Instr (Call (res, fct, args, _)) -> + get_node env (Vcall (s, res, fct, args)) + | Block b -> get_node env (VblkIn (Bstmt s,b)) + | UnspecifiedSequence seq -> + let b = Cil.block_from_unspecified_sequence seq in + get_node env (VblkIn (Bstmt s,b)) + | If (e, _, _, _) -> get_node env (Vtest (true, s, e)) + | Loop _ -> get_node env (Vloop (None, s)) + | Break _ | Continue _ | Goto _ + | Instr _ | Return _ -> get_node env (Vstmt s) + | Switch (e, _, _, _) -> get_node env (Vswitch (s, e)) + | TryExcept _ | TryFinally _ -> + Wp_parameters.not_yet_implemented "[cfg] exception handling" + + +(** build the nodes for the [stmts], connect the last one with [next], +* and return the node of the first stmt. ) +let rec cfg_stmts env stmts next = match stmts with +| [] -> next +| [s] -> cfg_stmt env s next +| s::tl -> + let next = cfg_stmts env tl next in + let ns = cfg_stmt env s next in + ns + +and cfg_block env bkind b next = + ( + match b.bstmts with + | [] -> next + | _ -> + ) + let in_blk = get_node env (VblkIn (bkind, b)) in + let _ = add_edge env in_blk Enext next in + let out_blk = get_node env (VblkOut (bkind, b)) in + let _ = add_edge env out_blk Enone next in + let first_in_blk = cfg_stmts env b.bstmts out_blk in + let _ = add_edge env in_blk Enone first_in_blk in + in_blk + +and cfg_switch env switch_stmt switch_exp blk case_stmts next = + let n_switch = get_node env (Vswitch (switch_stmt, switch_exp)) in + add_edge env n_switch Enext next; + let _first = cfg_stmts env blk.bstmts next in + let branch with_def s = + let n = get_stmt_node env s in + let rec find_case l = match l with + | [] -> false, [] + | Case (e, _)::tl -> + let r = match find_case tl with + | true, [] -> true, [] + | true, _ -> assert false + | false, l -> false, e::l + in r + | Default _ :: _ -> + ( we don't check if we have several Default because it is impossible: + * CIL gives an error ) + true, [] + | _::tl -> find_case tl + in + let def, case = find_case s.labels in + if case = [] && not def then + Wp_parameters.fatal "[cfg] switch branch without label"; + add_edge env n_switch (Ecase case) n; + if def then true else with_def + in + let with_def = List.fold_left branch false case_stmts in + let _ = if not with_def then add_edge env n_switch (Ecase []) next in + n_switch + +and cfg_stmt env s next = + !Db.progress (); + match s.skind with + | Instr (Call _) -> + let in_call = get_stmt_node env s in + add_edge env in_call Enone next; + let exit_node = get_node env (Vexit) in + add_edge env in_call Enone exit_node; + in_call + | Instr _ | Return _ -> + let n = get_stmt_node env s in + add_edge env n Enone next; + n + | Block b -> + cfg_block env (Bstmt s) b next + | UnspecifiedSequence seq -> + let b = Cil.block_from_unspecified_sequence seq in + cfg_block env (Bstmt s) b next + | If (e, b1, b2, _) -> + begin + let n_in = get_stmt_node env s (get_node env (Vtest (true, s, e))) in + let n_out = get_node env (Vtest (false, s, e)) in + ( this node is to ensure that there is only one edge before + * the [next] node of a if to put post properties about the IF. ) + add_edge env n_out Enone next; + let in_b1 = cfg_block env (Bthen s) b1 n_out in + let in_b2 = cfg_block env (Belse s) b2 n_out in + add_edge env n_in Ethen in_b1; + add_edge env n_in Eelse in_b2; + add_edge env n_in Enext next; + n_in + end + | Loop(_, b, _, _, _) -> + let loop = get_stmt_node env s in + add_edge env loop Enext next; + let in_b = cfg_block env (Bloop s) b loop in + add_edge env loop Enone in_b; + loop + | Break _ | Continue _ | Goto _ -> + let n = get_stmt_node env s in + let _ = match s.succs with + | [s'] -> add_edge env n Enone (get_stmt_node env s') + | _ -> Wp_parameters.fatal "[cfg] jump with more than one successor ?" + in n + | Switch (e, b, lstmts, _) -> + cfg_switch env s e b lstmts next + | TryExcept _ | TryFinally _ -> + Wp_parameters.not_yet_implemented "[cfg] exception handling" + +() +( {3 Cleaning} remove node and edges that are unreachable ) + +let clean_graph cfg = + let graph = cfg_graph cfg in + let rec reach n = + if !n.reachable then () + else (!n.reachable <- true; iter_succ reach cfg n) + in reach (cfg_start cfg); + let clean n acc = + if !n.reachable then acc + else begin + debug "remove unreachable node %a@." VL.pretty n; + let v = node_type n in + CFG.remove_vertex graph n; + Hashtbl.remove cfg.stmt_node (node_type_id v); + v::acc + end + in + let unreach = fold_nodes clean cfg [] in + { cfg with unreachables = unreach } + + +() +( {3 About loops} +* Let's first remind some definitions about loops : +* - {b back edge} : edge n->h such that h dominates n. +* - {b natural loop} : defined by a back edge n->h +* * h is called the {b loop header}, +* * the body of the loop is the set of nodes n that are "between" h and n, +* ie all n predecessors until h. +* Because h dominates n, every backward path from n go through h. +* Notice that each node in the loop body is dominated by h. +* +* A loop is not a natural loop if it has several entries (no loop header), +* or if it has some irreducible region (no back edge). +* +* Below, we use an algorithm from the paper : + * "A New Algorithm for Identifying Loops in Decompilation" + * of Tao Wei, Jian Mao, Wei Zou, and Yu Chen, + * to gather information about the loops in the builted CFG. + *) + +module type WeiMaoZouChenInput = sig + type graph + type node + type tenv + + (** build a new env from a graph, + * and also return the entry point of the graph which has to be unique. ) + val init : graph -> tenv node + + (** apply the function on the node successors *) + val fold_succ : (tenv -> node -> tenv) -> tenv -> node -> tenv + + val eq_nodes : node -> node -> bool + + (** store the position for the node and also the fact that the node has + * been seen *) + val set_pos : tenv -> node -> int -> tenv + + (** reset the position (set the position to 0), but should keep the + * information that the node has been seen already. *) + val reset_pos : tenv -> node -> tenv + + (** get the previously stored position of the node or 0 if nothing has been + * stored *) + val get_pos : tenv -> node -> int + + (** get the previously stored position of the node if any, or None + * if [set_pos] hasn't been called already for this node. *) + val get_pos_if_traversed : tenv -> node -> int option + + (** [set_iloop_header env b h] store h as the innermost loop header for b. + * Beware that this function can be called several times for the same b + * with different values of h during the computation. Only the last one + * will give the correct information. + * *) + val set_iloop_header : tenv -> node -> node -> tenv + + (** get the node innermost loop header if any *) + val get_iloop_header : tenv -> node -> node option + + (** store the node as a loop header. *) + val add_loop_header : tenv -> node -> tenv + + (** store the node as an irreducible loop header. *) + val add_irreducible : tenv -> node -> tenv + + (** store the edge between the two nodes (n1, n2) as a reentry edge. + * n2 is the reentry point which means that it is in a loop, + * but it is not the loop header, and n1 is not in the loop. *) + val add_reentry_edge : tenv -> node -> node -> tenv + + val pretty_node : Format.formatter -> node -> unit + + (** the unstructuredness coefficient k can be computed = 1+(xi+yi)/E + * when E is the number of edge in the graph. + * See the paper for more details. + * Just do nothing in [incr_xi] and [incr_yi] if you don't need k. + * *) + val incr_xi : tenv -> tenv + val incr_yi : tenv -> tenv +end + +(** Implementation of + * "A New Algorithm for Identifying Loops in Decompilation" ) +module WeiMaoZouChen (G : WeiMaoZouChenInput) : sig + val identify_loops : G.graph -> G.tenv +end = struct + + let tag_lhead env b h = + match h with + | None -> env + | Some h -> + if G.eq_nodes h b then ( already done ) env + else + let rec do_cur env cur_b cur_h = + match G.get_iloop_header env cur_b with + | None -> G.set_iloop_header env cur_b cur_h + | Some hb when G.eq_nodes hb cur_h -> ( nothing to do *) env + | Some hb -> + if (G.get_pos env hb) < (G.get_pos env cur_h) then + let env = G.set_iloop_header env cur_b cur_h in + do_cur env cur_h hb + else do_cur env hb cur_h + in do_cur env b h + + (** @return innermost loop header of b0 (None if b0 is not in a loop) ) + let rec trav_loops_DFS env b0 pos = + let env = G.set_pos env b0 pos in + let do_b env b = + match G.get_pos_if_traversed env b with + | None -> ( case A : b is not traversed already ) + let env, nh = trav_loops_DFS env b (pos + 1) in + tag_lhead env b0 nh + | Some b_pos when (b_pos > 0) -> + begin ( case B : b already in path -> it is a loop ) + let env = G.add_loop_header env b in + tag_lhead env b0 (Some b) + end + | Some 0 -> + begin + match G.get_iloop_header env b with + | None -> ( case C : do nothing ) env + | Some h when (G.get_pos env h > 0) -> + ( case D : b not in path, but h is ) + tag_lhead env b0 (Some h) + | Some h -> ( h not in path ) + begin ( case E : reentry ) + assert (G.get_pos env h = 0); + let env = G.add_irreducible env h in + let env = G.add_reentry_edge env b0 b in + let rec f env h = match G.get_iloop_header env h with + | Some h when (G.get_pos env h > 0) -> + tag_lhead env b0 (Some h) + | Some h -> + let env = G.add_irreducible env h in + f env h + | None -> env + in f env h + end + end + | _ -> assert false ( b_pos cannot be < 0 *) + in + let env = G.fold_succ do_b env b0 in + let env = G.reset_pos env b0 in + let h0 = G.get_iloop_header env b0 in + env, h0 + + let identify_loops g = + let env, start = G.init g in + let env, _ = trav_loops_DFS env start 1 in + env + +end + +(** To use WeiMaoZouChen algorithm, + * we need to define how to interact with our CFG graph ) +module LoopInfo = struct + type node = CFG.V.t + type graph = t + type tenv = { graph : t ; + dfsp : (node, int) Hashtbl.t; + iloop_header : (node, node) Hashtbl.t; + loop_headers : node list ; + irreducible : node list ; + unstruct_coef : int } + + let init cfg = + let env = { graph = cfg ; + dfsp = Hashtbl.create 97; iloop_header = Hashtbl.create 7; + loop_headers = []; irreducible = []; unstruct_coef = 0 } in + env, cfg_start cfg + + let eq_nodes = CFG.V.equal + + let set_pos env n pos = Hashtbl.add env.dfsp n pos; env + let reset_pos env n = Hashtbl.replace env.dfsp n 0; env + let get_pos env n = try Hashtbl.find env.dfsp n with Not_found -> 0 + let get_pos_if_traversed env n = + try Some (Hashtbl.find env.dfsp n) with Not_found -> None + + let set_iloop_header env b h = Hashtbl.add env.iloop_header b h; env + let get_iloop_header env b = + try Some (Hashtbl.find env.iloop_header b) with Not_found -> None + + let add_loop_header env h = { env with loop_headers = h :: env.loop_headers} + let add_irreducible env h = { env with irreducible = h :: env.irreducible} + let add_reentry_edge env _ _ = ( TODO ) env + + let is_irreducible env h = List.exists (eq_nodes h) env.irreducible + + let fold_succ f env n = fold_succ (fun v env -> f env v) env.graph n env + + let incr env = {env with unstruct_coef = env.unstruct_coef + 1} + let incr_xi = incr + let incr_yi = incr + let unstructuredness env = + let k = float_of_int env.unstruct_coef in + let k = k /. (float_of_int (CFG.nb_edges (cfg_graph env.graph))) in + let k = 1. +. k in + k + + let pretty_node fmt n = Format.fprintf fmt "%d" (VL.hash n) +end + +module Mloop = WeiMaoZouChen (LoopInfo) + +module HEloop = HE (struct type t = Nset.t end) + +let set_back_edge e = + let info = CFG.E.label e in + match !info with + | Eback | EbackThen | EbackElse -> () + | Enone -> info := Eback + | Ethen -> info := EbackThen + | Eelse -> info := EbackElse + | Ecase _ | Enext -> assert false + +let mark_loops cfg = + let kf = cfg_kf cfg in + let env = Mloop.identify_loops cfg in + let mark_loop_back_edge h = match node_stmt_opt h with + | None -> ( Because we use !Db.Dominators that work on statements, + we don't know how to detect back edge here. + TODO: compute dominators on our cfg ? ) false + | Some h_stmt -> + let mark_back_edge e = + let n = edge_src e in + let is_back_edge = + try + let n_stmt = node_stmt_exn n in + !Db.Dominators.is_dominator kf ~opening:h_stmt ~closing:n_stmt + with Not_found -> false ( pred of h is not a stmt ) + in + if is_back_edge then set_back_edge e; + debug "to loop edge %a@." pp_edge e + in iter_pred_e mark_back_edge cfg h; true + in + let mark_loop loops h = + debug "loop head in %a@." VL.pretty h; + let is_natural = + if (LoopInfo.is_irreducible env h) then + (debug "irreducible loop detected in %a@." VL.pretty h; false) + else true + in let back_edges_ok = + if is_natural then mark_loop_back_edge h else true + in + let loop = match node_type h with + | Vloop (_, h_stmt) -> + assert (back_edges_ok); + h := { !h with kind = Vloop (Some is_natural, h_stmt)}; + h + | _ -> match node_stmt_opt h with + | Some h_stmt when back_edges_ok -> + insert_loop_node cfg h (Vloop (Some is_natural, h_stmt)) + | None when back_edges_ok -> + let n = cfg.loop_cpt in cfg.loop_cpt <- n + 1; + insert_loop_node cfg h (Vloop2 (is_natural, n)) + | _ -> ( consider it has non-natural. ) + let n = cfg.loop_cpt in cfg.loop_cpt <- n + 1; + insert_loop_node cfg h (Vloop2 (false, n)) + in loop::loops + in + let loops = List.fold_left mark_loop [] env.LoopInfo.loop_headers in + debug2 "unstructuredness coef = %f@." (LoopInfo.unstructuredness env); + { cfg with loop_nodes = Some loops } + +let loop_nodes cfg = match cfg.loop_nodes with Some l -> l + | None -> Wp_parameters.fatal + "Cannot use the loop nodes before having computed them" + +let strange_loops cfg = + let strange n = match node_type n with + | Vloop (Some is_natural, _) when is_natural -> false + | _ -> true + in let loops = loop_nodes cfg in + let strange_loops = List.filter strange loops in + debug "%d/%d strange loops" + (List.length strange_loops) (List.length loops); + strange_loops + +let very_strange_loops cfg = + let strange n = match node_type n with + | Vloop (Some _, _) | Vloop2 _ -> false + | _ -> true + in let loops = loop_nodes cfg in + let strange_loops = List.filter strange loops in + debug "%d/%d very strange loops" + (List.length strange_loops) (List.length loops); + strange_loops + +(~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) +(** {3 Create CFG} ) + +let cfg_from_definition kf f = + let kf_name = Kernel_function.get_name kf in + let cfg, fct_in, fct_out = init_cfg false kf in + let in_b = cfg_block cfg Bfct f.sbody fct_out in + let _ = add_edge cfg fct_in Enone in_b in + let graph = cfg_graph cfg in + debug "for function '%s': %d vertex - %d edges@." + kf_name (CFG.nb_edges graph) (CFG.nb_vertex graph); + debug + "start removing unreachable in %s@." kf_name; + !Db.progress (); + let cfg = clean_graph cfg in + debug "for function '%s': %d vertex - %d edges@." + kf_name (CFG.nb_edges graph) (CFG.nb_vertex graph); + !Db.progress (); + debug + "start loop analysis for %s@." kf_name; + let cfg = mark_loops cfg in + cfg + +let cfg_from_proto kf = + let cfg, fct_in, fct_out = init_cfg true kf in + let _ = add_edge cfg fct_in Enone fct_out in + let cfg = { cfg with loop_nodes = Some [] } in + cfg + +( ------------------------------------------------------------------------ *) +(** {2 Export dot graph} *) + +(** {3 Printer for ocamlgraph} ) + +module Printer (PE : sig val edge_txt : edge -> string end) = struct + type t = CFG.t (edge -> string) + module V = CFG.V + module E = CFG.E + let iter_edges_e f (g, _f) = CFG.iter_edges_e f g + let iter_vertex f (g, _) = CFG.iter_vertex f g + + let graph_attributes _t = [] + + let pretty_raw_stmt s = + let s = Pretty_utils.sfprintf "%a" !Ast_printer.d_stmt s in + let s' = if String.length s >= 50 then (String.sub s 0 49) ^ "..." else s in + String.escaped s' + + let vertex_name v = + let n = V.label v in (string_of_int (VL.hash n)) + + let vertex_attributes v = + let n = V.label v in + let label = match node_type n with + | Vstart -> "Start" | Vend -> "End" | Vexit -> "Exit" + | VfctIn -> "FctIn" | VfctOut -> "FctOut" + | VblkIn (bk,_) -> Pretty_utils.sfprintf "BLOCKin <%a>" pp_bkind bk + | VblkOut (bk,_) -> Pretty_utils.sfprintf "BLOCKout <%a>" pp_bkind bk + | Vcall _ -> Format.sprintf "CALL" + | Vtest (true, s, e) -> + Pretty_utils.sfprintf "IF <%d>\n%a" s.sid !Ast_printer.d_exp e + | Vtest (false, s, _e) -> Pretty_utils.sfprintf "IFout <%d>" s.sid + | Vstmt s | Vloop (_, s) | Vswitch (s, _) -> + begin match s.skind with + | Instr _ -> Format.sprintf "INSTR <%d>\n%s" s.sid (pretty_raw_stmt s) + | If _ -> "invalid IF ?" + | Return _ -> Format.sprintf "RETURN <%d>" s.sid + | Goto _ -> Format.sprintf "%s <%d>" (pretty_raw_stmt s) s.sid + | Break _ -> Format.sprintf "BREAK <%d>" s.sid + | Continue _ -> Format.sprintf "CONTINUE <%d>" s.sid + | Switch _ -> Format.sprintf "SWITCH <%d>" s.sid + | Loop _ -> Format.sprintf "WHILE(1) <%d>" s.sid + | Block _ -> Format.sprintf "BLOCK??? <%d>" s.sid + | TryExcept _ -> Format.sprintf "TRY EXCEPT <%d>" s.sid + | TryFinally _ -> Format.sprintf "TRY FINALLY <%d>" s.sid + | UnspecifiedSequence _ -> Format.sprintf "UnspecifiedSeq <%d>" s.sid + end + | Vloop2 (_, n) -> Format.sprintf "Loop-%d" n + in + let attr = match node_type n with + | Vstart | Vend | Vexit -> [`Color 0x0000FF; `Shape `Doublecircle] + | VfctIn | VfctOut -> [`Color 0x0000FF; `Shape `Box] + | VblkIn _ | VblkOut _ -> [`Shape `Box] + | Vloop _ | Vloop2 _ -> [`Color 0xFF0000; `Style `Filled] + | Vtest _ | Vswitch _ -> [`Color 0x00FF00; `Style `Filled; `Shape `Diamond] + | Vcall _ | Vstmt _ -> [] + in (`Label (String.escaped label))::attr + + let default_vertex_attributes _v = [] + + let edge_attributes e = + let attr = [] in + let attr = (`Label (String.escaped (PE.edge_txt e)))::attr in + let attr = + if is_back_edge e then (`Constraint false)::(`Style `Bold)::attr + else attr + in + let attr = match (edge_type e) with + | Ethen | EbackThen -> (`Color 0x00FF00)::attr + | Eelse | EbackElse -> (`Color 0xFF0000)::attr + | Ecase [] -> (`Color 0x0000FF)::(`Style `Dashed)::attr + | Ecase _ -> (`Color 0x0000FF)::attr + | Enext -> (`Style `Dotted)::attr + | Eback -> attr (* see is_back_edge above ) + | Enone -> attr + in + attr + + let default_edge_attributes _ = [] + + let get_subgraph v = + let mk_subgraph name attrib = + let attrib = (`Style `Filled) :: attrib in + Some { Graph.Graphviz.DotAttributes.sg_name= name; + Graph.Graphviz.DotAttributes.sg_attributes = attrib } + in + match node_type (V.label v) with + | Vcall (s,_,_,_) -> + let name = Format.sprintf "Call_%d" s.sid in + let call_txt = pretty_raw_stmt s in + let label = Format.sprintf "Call <%d> : %s" s.sid call_txt in + let attrib = [(`Label label)] in + let attrib = (`Fillcolor 0xB38B4D) :: attrib in + mk_subgraph name attrib + | _ -> None + +end + +( ---------------------------------- *) +(** {3 Export to dot file} ) + +type pp_edge_fun = Format.formatter -> edge -> unit + +let export ~file ?pp_edge_fun cfg = + Kernel.Unicode.without_unicode + (fun () -> + let edge_txt = match pp_edge_fun with + | None -> + (fun e -> match (edge_type e) with + | Ecase (_::_) -> Pretty_utils.sfprintf "%a" EL.pretty (edge_type e) + | _ -> "" + ) + | Some pp -> (fun e -> Pretty_utils.sfprintf "%a" pp e) + in + let module P = Printer (struct let edge_txt = edge_txt end) in + let module GPrint = Graph.Graphviz.Dot(P) in + ( [JS 2011/03/11] open_out and output_graph (and close_out?) may raise + exception. Should be caught. ) + let oc = open_out file in + GPrint.output_graph oc (cfg_graph cfg, edge_txt); + close_out oc + ) () + +let cfg_dot msg dotname ?pp_edge_fun cfg = + let dir = Wp_parameters.get_output () in + let file = Printf.sprintf "%s/wp_%s.dot" dir dotname in + Wp_parameters.result "export %s in %s@." msg file ; + export ~file ?pp_edge_fun cfg ; + file + +let dot_cfg cfg = + let kf = cfg_kf cfg in + let kf_name = Kernel_function.get_name kf in + let dotname = kf_name^".cfg" in + cfg_dot "cfg" dotname cfg + +let dot_annots cfg bhv_name pp_edge_fun = + let kf = cfg_kf cfg in + let kf_name = Kernel_function.get_name kf in + let name = match bhv_name with + | None -> + Printf.sprintf "%s.wp_annot_cfg" kf_name + | Some bhv -> + Printf.sprintf "%s_%s.wp_annot_cfg" kf_name bhv + in + cfg_dot "cfg" name cfg ~pp_edge_fun + +let dot_wp_res cfg model pp_edge_fun = + let kf = cfg_kf cfg in + let f = Kernel_function.get_name kf in + let msg = (model^" results") in + let dotname = (f^".wp_"^model) in + cfg_dot msg dotname cfg ~pp_edge_fun + +( ------------------------------------------------------------------------ *) +(** {2 CFG management} ) + +let create kf = + let kf_name = Kernel_function.get_name kf in + debug "create cfg for function '%s'@." kf_name; + let cfg = + try + let f = Kernel_function.get_definition kf in + cfg_from_definition kf f + with Kernel_function.No_Definition -> + cfg_from_proto kf + in debug "done for %s@." kf_name; + if Wp_parameters.Dot.get () then ignore (dot_cfg cfg); + !Db.progress (); + cfg + +module KfCfg = + Kernel_function.Make_Table + (Datatype.Make + (struct + include Datatype.Undefined + type tt = t + type t = tt + let name = "WpCfg" + let mem_project = Datatype.never_any_project + let reprs = + List.map + (fun kf -> + { kernel_function = kf; + spec_only = true; + graph = CFG.create (); + stmt_node = Hashtbl.create 0; + start_id = -1; + unreachables = []; + loop_nodes = None; + loop_cpt = 0; + } + ) + Kernel_function.reprs + let equal t1 t2 = + Kernel_function.equal t1.kernel_function t2.kernel_function + let hash t = Kernel_function.hash t.kernel_function + let compare t1 t2 = + Kernel_function.compare t1.kernel_function t2.kernel_function + end)) + (struct let name = "KfCfg" + let dependencies = [Ast.self] + let kind = `Internal + let size = 17 + end) + +let get kf = KfCfg.memo create kf + +( ------------------------------------------------------------------------ ) + +( +Local Variables: +compile-command: "make" +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/cil2cfg.mli frama-c-20111001+nitrogen+dfsg/src/wp/cil2cfg.mli --- frama-c-20110201+carbon+dfsg/src/wp/cil2cfg.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/cil2cfg.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,178 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +open Cil_types + +( abstract type of a cfg *) +type t + +(** @raise Log.FeatureRequest for non natural loops and 'exception' stmts. + * @return the graph and the list of unreachable nodes. + * *) +val get : Kernel_function.t -> t + +(** abstract type of the cfg nodes *) +type node +val pp_node : Format.formatter -> node -> unit +val same_node : node -> node -> bool + +(** abstract type of the cfg edges *) +type edge +val pp_edge : Format.formatter -> edge -> unit +val same_edge : edge -> edge -> bool + +(** get the starting edges *) +val start_edge : t -> edge + +(** set of edges *) +module Eset : Set.S with type elt = edge + +(** node and edges relations *) +val edge_src : edge -> node +val edge_dst : edge -> node +val pred_e : t -> node -> edge list +val succ_e : t -> node -> edge list + +(** iterators *) +val fold_nodes : (node -> 'a -> 'a) -> t -> 'a -> 'a +val iter_nodes : (node -> unit) -> t -> unit +val iter_edges : (edge -> unit) -> t -> unit + +(** Be careful that only Bstmt are real Block statements ) +type block_type = private + | Bstmt of stmt | Bthen of stmt | Belse of stmt | Bloop of stmt | Bfct + +type node_type = private + | Vstart | Vend | Vexit + | VfctIn | VfctOut + | VblkIn of block_type block + | VblkOut of block_type * block + | Vstmt of stmt + | Vcall of stmt * lval option * exp * exp list + | Vtest of bool * stmt * exp + | Vswitch of stmt * exp + | Vloop of bool option * stmt + (** boolean is is_natural. None means the node has not been + * detected as a loop. ) + | Vloop2 of bool int + +val node_type : node -> node_type +val pp_node_type : Format.formatter -> node_type -> unit + +val node_stmt_opt : node -> stmt option +val start_stmt_of_node : node -> stmt option + +(** @return the nodes that are unreachable from the 'start' node. +* These nodes have been removed from the cfg already. *) +val unreachable_nodes : t -> node_type list + +(** similar to [succ_e g v] +* but tests the branch to return (then-edge, else-edge) + * @raise Invalid_argument if the node is not a test. +* ) +val get_test_edges : t -> node -> edge edge + +(** similar to [succ_e g v] +but give the switch cases and the default edge ) +val get_switch_edges : t -> node -> (exp list edge) list * edge + +(** similar to [succ_e g v] +but gives the edge to VcallOut first and the edge to Vexit second. ) +val get_call_out_edges : t -> node -> edge edge + +val blocks_closed_by_edge : t -> edge -> block list + +val is_back_edge : edge -> bool + +(** detect is there are non natural loops or natural loops where we didn't +* manage to compute back edges (see [mark_loops]). Must be empty in the mode +* [-wp-no-invariants]. (see also [very_strange_loops]) *) +val strange_loops : t -> node list + +(** detect is there are natural loops where we didn't manage to compute +* back edges (see [mark_loops]). At the moment, we are not able to handle those +* loops. *) +val very_strange_loops : t -> node list + +(** @return the (normalized) labels at the program point of the edge. *) +val get_edge_labels : edge -> Clabels.c_label list + +(** @return None when the edge leads to the end of the function. *) +val get_edge_next_stmt : t -> edge -> stmt option + +(** wether an exit edge exists or not *) +val has_exit : t -> bool + +(** Find the edges where the precondition of the node statement have to be +* checked. *) +val get_pre_edges : t -> node -> edge list + +(** Find the edges where the postconditions of the node statement have to be +* checked. *) +val get_post_edges : t -> node -> edge list + +(** Get the label to be used for the Post state of the node contract if any. *) +val get_post_logic_label : t -> node -> logic_label option + +(** Find the edges [e] that goes to the [Vexit] node inside the statement +* begining at node [n] *) +val get_exit_edges : t -> node -> edge list + +(** Find the edges [e] of the statement node [n] postcondition +* and the set of edges that are inside the statement ([e] excluded). +* For instance, for a single statement node, [e] is [succ_e n], +* and the set is empty. For a test node, [e] are the last edges of the 2 +* branches, and the set contains all the edges between [n] and the [e] edges. +* ) +val get_internal_edges : t -> node -> edge list Eset.t + +val cfg_kf : t -> Kernel_function.t +val cfg_spec_only : t -> bool + (** returns [true] is this CFG is degenerated (no code available) *) + +(** signature of a mapping table from cfg edges to some information. *) +module type HEsig = +sig + type ti + type t + val create : int -> t + val find : t -> edge -> ti + val find_all : t -> edge -> ti list + val add : t -> edge -> ti -> unit + val replace : t -> edge -> ti -> unit + val remove : t -> edge -> unit + val clear : t -> unit +end + +module HE (I : sig type t end) : HEsig with type ti = I.t + +(** type of functions to print things related to edges *) +type pp_edge_fun = Format.formatter -> edge -> unit + +( Output the graph in a dot file and return its name ) +val dot_cfg : t -> string + +(** [dot_annots cfg bhv_name pp_annots] *) +val dot_annots : t -> string option -> pp_edge_fun -> string + +(** [dot_wp_res cfg model pp_wp_res] *) +val dot_wp_res : t -> string -> pp_edge_fun -> string diff -Nru frama-c-20110201+carbon+dfsg/src/wp/clabels.ml frama-c-20111001+nitrogen+dfsg/src/wp/clabels.ml --- frama-c-20110201+carbon+dfsg/src/wp/clabels.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/clabels.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,116 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Normalized C-labels --- ) +( -------------------------------------------------------------------------- ) + +open Cil_types + +type c_label = + | Here + | Pre + | Post + | Exit + | At of string list int + | CallAt of int + | LabelParam of string + + +let has_prefix p s = + let rec scan k p s = + ( k >= String.length p ) || + ( k < String.length s && p.[k] = s.[k] && scan (succ k) p s ) + in scan 0 p s + +let rec names_at = function + | [] -> [] + | Default _ :: labels -> "default" :: names_at labels + | Label(l,_,_) :: labels -> + (TODO [LC] see mk_logic_label and loop_head_label ) + if has_prefix "wp!" l || has_prefix "return_label" l + then names_at labels + else l :: names_at labels + | Case(e,_) :: labels -> + match Ctypes.get_int e with + | None -> "case" :: names_at labels + | Some n -> + if n < 0L + then ("caseneg" ^ Int64.to_string (Int64.neg n)) :: names_at labels + else ("case" ^ Int64.to_string n) :: names_at labels + +let c_label = function + | LogicLabel (None, "Here") -> Here + | LogicLabel (None, "Pre") -> Pre + | LogicLabel (None, "Post") -> Post + | LogicLabel (None, "Exit") -> Exit + | LogicLabel (None, l) -> LabelParam l + | LogicLabel (Some stmt, _) + | StmtLabel { contents=stmt } -> At(names_at stmt.labels,stmt.sid) + +(TODO [LC] : Use extension of Clabels instead ) +let loop_head_label s = + LogicLabel (None, "wp!loop_"^(string_of_int s.sid)^"_head") + +(TODO [LC] : Use extension of Clabels instead ) +let mk_logic_label s = + LogicLabel (Some s, "wp!stmt_"^(string_of_int s.sid)) + +let mk_stmt_label s = (* TODO: clean that !) c_label (mk_logic_label s) +let mk_loop_label s = ( TODO: clean that !) c_label (loop_head_label s) + +let pretty fmt = function + | Here -> Format.pp_print_string fmt "\\here" + | Pre -> Format.pp_print_string fmt "\\pre" + | Post -> Format.pp_print_string fmt "\\post" + | Exit -> Format.pp_print_string fmt "\\exit" + | LabelParam label -> Format.fprintf fmt "Label '%s'" label + | CallAt sid -> Format.fprintf fmt "Call sid:%d" sid + | At(label::_,_) -> Format.fprintf fmt "Stmt '%s'" label + | At([],sid) -> Format.fprintf fmt "Stmt sid:%d" sid + +let label f a x = + if Wp_parameters.Trace.get () then + match a with + | Here | Pre | Post | Exit -> x + | LabelParam label -> + (TODO [LC] see mk_logic_label and loop_head_label *) + if has_prefix "wp!" label + then x + else f label x + | CallAt sid -> + if Wp_parameters.debug_atleast 1 + then f (Printf.sprintf "Call%d" sid) x else x + | At(labels,sid) -> + List.fold_left + (fun x label -> f label x) + (if Wp_parameters.debug_atleast 1 + then f (Printf.sprintf "Stmt%d" sid) x else x) + labels + else x + +let lookup labels param = + try + let is_param p = function (LogicLabel (None, a),_) -> a = p | _ -> false in + c_label (snd (List.find (is_param param) labels)) + with Not_found -> Wp_parameters.fatal + "Unbound label parameter '%s' in predicate or function call" param diff -Nru frama-c-20110201+carbon+dfsg/src/wp/clabels.mli frama-c-20111001+nitrogen+dfsg/src/wp/clabels.mli --- frama-c-20110201+carbon+dfsg/src/wp/clabels.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/clabels.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,67 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Normalized C-labels ) +( -------------------------------------------------------------------------- *) + +(** + Structural representation of logic labels. + Compatible with pervasives comparison and structural equality. +) + +type c_label = + | Here + | Pre + | Post + | Exit + | At of string list int (** Label name, stmt-id. *) + | CallAt of int (** stmt-id *) + | LabelParam of string (** Logic label name in user-defined + function or predicate *) + +(** @return a label that represent the first point of a loop body. *) +val loop_head_label : Cil_types.stmt -> Cil_types.logic_label + +(** create a virtual label to a statement (it can have no label) *) +val mk_logic_label : Cil_types.stmt -> Cil_types.logic_label + +val mk_stmt_label : Cil_types.stmt -> c_label +val mk_loop_label : Cil_types.stmt -> c_label + +val c_label : Cil_types.logic_label -> c_label + (** + Assumes the logic label only comes from normalized labels. + + This is the case inside [Wp] module, where all ACSL formula comes + from [WpAnnot], which in turns always preprocess the labels + through [NormAtLabels]. + ) + +val pretty : Format.formatter -> c_label -> unit +val label : (string -> 'a -> 'a) -> c_label -> 'a -> 'a + +open Cil_types + +val lookup : (logic_label logic_label) list -> string -> c_label + (** [lookup bindings lparam] retrieves the actual label + for the label in [bindings] for label parameter [lparam]. ) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/configure frama-c-20111001+nitrogen+dfsg/src/wp/configure --- frama-c-20110201+carbon+dfsg/src/wp/configure 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/configure 2011-10-10 08:56:40.000000000 +0000 @@ -0,0 +1,3759 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.65. +# +# +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, +# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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. +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 + +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" + 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 : + # 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. + BASH_ENV=/dev/null + ENV=/dev/null + (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} +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_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 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=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 + fi + $as_echo "$as_me: error: $1" >&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; } + + # 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 -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +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 + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]):;;)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# 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 </dev/null +exec 6>&1 + +# Name of the host. +# hostname on some systems (SVR3.2, 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="Makefile.in" +ac_subst_vars='ALTERGO_VERSION +LTLIBOBJS +LIBOBJS +COQ +HAS_COQ +ALTERGO +HAS_ALTERGO +WHYDP +HAS_WHYDP +WHY +HAS_WHY +DYNAMIC_WP +ENABLE_WP +ENABLE_GUI +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 +enable_wp +with_wp_static +' + 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=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 + $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 + 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 + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-wp support for wp plug-in (default: yes) + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-wp-static link wp statically (default: no) + +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.65 + +Copyright (C) 2009 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.65. 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 + + cat <<\_ASBOX +## ---------------- ## +## Cache variables. ## +## ---------------- ## +_ASBOX + 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 + + cat <<\_ASBOX +## ----------------- ## +## Output variables. ## +## ----------------- ## +_ASBOX + 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 + cat <<\_ASBOX +## ------------------- ## +## File substitutions. ## +## ------------------- ## +_ASBOX + 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 + cat <<\_ASBOX +## ----------- ## +## confdefs.h. ## +## ----------- ## +_ASBOX + 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 + ac_site_file1=$CONFIG_SITE +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" + 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 + + + KNOWN_PLUGINS=$(frama-c -help | \ + sed -e '0,/^\\\\\/ d' \ + -e 's/$[^ ][^ ]\( [^ ][^ ]$\) ./\1/' \ + -e '/^ /d' -e '/^$/d' | \ + tr "a-z- " "A-Z__") + for plugin in ${KNOWN_PLUGINS}; do + export $(echo ENABLE_$plugin)=yes + done + # Extract the first word of "frama-c-gui", so it can be a program name with args. +set dummy frama-c-gui; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_prog_ENABLE_GUI+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ENABLE_GUI"; then + ac_cv_prog_ENABLE_GUI="$ENABLE_GUI" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_ENABLE_GUI="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_ENABLE_GUI" && ac_cv_prog_ENABLE_GUI="no" +fi +fi +ENABLE_GUI=$ac_cv_prog_ENABLE_GUI +if test -n "$ENABLE_GUI"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ENABLE_GUI" >&5 +$as_echo "$ENABLE_GUI" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + + + +upper() { + echo "$1" | tr "a-z-" "A-Z_" +} + +lower() { + echo "$1" | tr "A-Z" "a-z" +} + + + +new_section() { + banner=`echo " $1 " | sed -e 's/.//g'` + title=`echo "* $1 " | tr "a-z" "A-Z"` + { $as_echo "$as_me:${as_lineno-$LINENO}: $banner" >&5 +$as_echo "$as_me: $banner" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: $title" >&5 +$as_echo "$as_me: $title" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: $banner" >&5 +$as_echo "$as_me: $banner" >&6;} +} + + + +# sadly, there's no way to define a new diversion beside the internal ones. +# hoping for the best here... + + + + +# to distinguish internal plugins, known by the main configure, from +# purely external plugins living in src/ and compiled together with the main +# frama-c + + + + # end of check_plugin + +# 1st param: uppercase name of the library +# 2nd param: file which must exist. This parameter can be a list of files. +# In this case, they will be tried in turn until one of them exists. The +# name of the file found will be put in the variable SELECTED_$1 +# 3d param: warning to display if problem +# 4th param: yes iff checking the library must always to be done +# (even if there is no plug-in using it) + + +# 1st param: uppercase name of the program +# 2nd param: program which must exist. See comment on configure_library() +# on how to deal with multiple choices for a given program. +# 3d param: warning to display if problem +# 4th param: yes iff checking the tool must always to be done +# (even if there is no plug-in using it) + + +EXTERNAL_PLUGINS= + + + + + + + + +# Implementation of an ordering $1 < $2: "" < yes < partial < no +lt_mark () { + first=`echo "$1" | sed -e 's/ .//' ` + second=`echo "$2" | sed -e 's/ .//' ` + case $first in + "") echo "true";; + "yes") + case $second in + "yes") echo "";; + "partial" | "no") echo "true";; + esac;; + "partial") + case $second in + "yes" | "partial") echo "";; + "no") echo "true";; + esac;; + "no") echo "";; + esac +} + +# Check and propagate marks to requires and users. +# $1: parent plugin +# $2: mark to propagate to requires +# $3: mark to propagate to users +check_and_propagate () { + # for each requiers + r=REQUIRE_$1 + eval require="\$$r" + for p in $require; do + up=`upper "$p"` + m=MARK_"$up" + eval mark="\$$m" + if test -z "$mark"; then + m=ENABLE_"$up" + eval mark="\$$m" + fi + if test `lt_mark "$mark" "$2" `; then + # update marks + eval MARK_$up=\"$2\"; + TODOLIST=$TODOLIST" "$p + # display a warning or an error if required + short_mark=`echo $2 | sed -e 's/ .//'` + lp=`lower $p` + reason=`echo $2 | sed -e 's/no ($.$)/\1/' ` + if test "$short_mark" = "no"; then + fp=FORCE_"$up" + if eval test "\$$fp" = "yes"; then + as_fn_error "$lp requested but $reason." "$LINENO" 5 + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $lp disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $lp disabled because $reason." >&2;} + fi + else + if test "$short_mark" = "partial"; then + reason=`echo $2 | sed -e 's/partial ($.$)/\1/' ` + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $lp only partially enable because $reason." >&5 +$as_echo "$as_me: WARNING: $lp only partially enable because $reason." >&2;} + fi + fi + eval INFO_$up=\", $reason\" + fi + done + # for each users + u=USE_$1 + eval use="\$$u" + for p in $use; do + up=`upper "$p"` + m=MARK_$up + eval mark="\$$m" + if test -z "$mark"; then + m=ENABLE_"$up" + eval mark="\$$m" + fi + if test `lt_mark "$mark" "$3" `; then + # update marks + eval MARK_$up=\"$3\"; + TODOLIST=$TODOLIST" "$p + # display a warning if required + lp=`lower $p` + reason=`echo $3 | sed -e 's/partial ($.$)/\1/' ` + if test "$reason" != "$3"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $lp only partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $lp only partially enabled because $reason." >&2;} + fi + eval INFO_$up=\", $reason\" + fi + done +} + +# checks direct dependencies of a plugin. Useful for dynamic plugins which +# have a dependency toward already installed (or not) plug-ins, since the old +# plugins are not in the TODO list from the beginning (and need not their +# mutual dependencies be rechecked anyway +check_required_used () { + ep=ENABLE_$1 + eval enabled=\$$ep + + if test "$enabled" != "no"; then + + r=REQUIRED_$1 + u=USED_$1 + m=MARK_$1 + eval required=\$$r + eval used=\$$u + eval $m=yes + + reason= + + for p in $required; do + up=`upper $p` + ec=ENABLE_$up + eval enabled=\$$ec + case `echo "$enabled" | sed -e 's/ .//'` in + "") reason="$p unknown";; + "yes" | "partial");; + "no") reason="$p not enabled";; + esac + done + if test -n "$reason"; then + eval $m=\"no\ $$reason$\" + p_name=`lower $1` + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p_name disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p_name disabled because $reason." >&2;} + eval INFO_$1=\", $reason\" + else + for p in $used; do + up=`upper $p` + ec=ENABLE_$up + eval enabled=\$$ec + case `echo "$enabled" | sed -e 's/ .//'` in + "") reason="$p unknown";; + "yes" | "partial");; + "no") reason="$p not enabled";; + esac + done + if test -n "$reason"; then + eval $m=\"partial\ $$reason$\" + p_name=`lower $1` + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p_name partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p_name partially enabled because $reason." >&2;} + eval INFO_$1=\", $reason\" + fi + fi + + else # $enabled = "no" + eval $m=\"no\" + fi +} + +# Recursively check the plug-in dependencies using the plug-in dependency graph +compute_dependency () { + plugin=`echo $TODOLIST | sed -e 's/ .//' ` + TODOLIST=`echo $TODOLIST | sed -e 's/[^ ] $.$/\1/' ` + + lplugin=`lower "$plugin"` + uplugin=`upper "$plugin"` + # new mark to consider + m=MARK_$uplugin + eval mark="\$$m" + # old mark to consider + r=REMEMBER_$uplugin + eval remember="\$$r" + # the exact mark (final result), + # also the old mark if plugin already visited + e=ENABLE_$uplugin + eval enable="\$$e" + #first visit. Performs additional checks over requirements. + if test -z "$mark"; then + check_required_used "$uplugin"; + eval mark=\$$m + fi + +# echo "plug-in $lplugin (mark=$mark, remember=$remember, enable=$enable)" + if test `lt_mark "$remember" "$mark"`; then + # visit the current plugin: + # mark <- max(mark, enable) + case `echo "$mark" | sed -e 's/ .//' ` in + "") echo "problem?"; exit 3;; + "yes") + if test -n "$enable"; then mark="$enable"; else mark="yes"; fi;; + "partial") if test "$enable" = "no"; then mark="no"; fi;; + "no") ;; + esac + # update plug-in attributes with the new mark +# echo "update attributes with $mark" + eval $m=\"$mark\" + eval $e=\"`echo "$mark" | sed -e 's/ .//' `\" + enable="$mark" + eval $r=\"$mark\" + # compute and propagate a new mark to requires and users + case `echo "$enable" | sed -e 's/ .//' ` in + "") echo "problem?"; exit 3;; + "yes") check_and_propagate $uplugin "yes" "yes";; + "partial") +# if a plug-in is partial, does not consider its dependencies as partial +# so the second argument is "yes" and not "partial" + check_and_propagate \ + "$uplugin" \ + "yes" \ + "yes";; + "no") + check_and_propagate \ + "$uplugin" \ + "no ($lplugin not enabled)" \ + "partial ($lplugin not enabled)";; + esac + fi + # recursively consider the next plugins + if test -n "$TODOLIST"; then + compute_dependency; + fi +} + + + + + + + + + + + + + + + + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Makefile.in" >&5 +$as_echo_n "checking for Makefile.in... " >&6; } +if test "${ac_cv_file_Makefile_in+set}" = set; 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 "Makefile.in"; then + ac_cv_file_Makefile_in=yes +else + ac_cv_file_Makefile_in=no +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file_Makefile_in" >&5 +$as_echo "$ac_cv_file_Makefile_in" >&6; } +if test "x$ac_cv_file_Makefile_in" = x""yes; then : + default=yes;plugin_present=yes +else + plugin_present=no;default=no +fi + + +FORCE=no + +# Check whether --enable-wp was given. +if test "${enable_wp+set}" = set; then : + enableval=$enable_wp; ENABLE=$enableval;FORCE=$enableval +else + ENABLE=$default + +fi + + +if test "$ONLY_KERNEL" = "yes" -a "$FORCE" = "no"; then + ENABLE=no +fi + + + +# Test to change for static plugin, dynamic option +#default_dyn=no +#define([PLUGIN_HELP_DYN], +# AC_HELP_STRING([--enable-PLUGIN_NAME-dynamic], +# [PLUGIN_MSG (default: static)]) +#define([PLUGIN_NAME_DYN],[PLUGIN_NAME]-dynamic) +#AC_ARG_ENABLE( +# [PLUGIN_NAME_DYN], +# PLUGIN_HELP_DYN, +# ENABLE=$enableval; +# FORCE=$enableval +# ENABLE=$default_dyn +#) +#eval ENABLE_DYNAMIC_$up=\$ENABLE + +if test "$plugin_present" = "no" -a "$FORCE" = "yes"; then + as_fn_error "wp is not available" "$LINENO" 5 +fi + +FORCE_WP=$FORCE +PLUGINS_FORCE_LIST=${PLUGINS_FORCE_LIST}" "FORCE_WP + +ENABLE_WP=$ENABLE +NAME_WP=wp +if test "$default" = "no" -a "$FORCE" = "no"; then + INFO_WP=" (not available by default)" +fi + +# Dynamic plug-ins configuration + + +# Check whether --with-wp-static was given. +if test "${with_wp_static+set}" = set; then : + withval=$with_wp_static; is_static=$withval +else + is_static=$IS_ALL_STATIC +fi + + + # is_static = "yes" iff the user forces the plug-in to be static + # is_static = "no" iff the user forces the plug-in to be dynamic + # is_static = "" in others cases (no special instruction) + STATIC_WP=$is_static + if test "$is_static" != "yes"; then + USE_NATIVE_DYNLINK="${USE_NATIVE_DYNLINK} wp" + DYNAMIC_WP=yes + else + DYNAMIC_WP=no + fi + + + +echo "wp... $ENABLE" +# kept defined for write_plugin_config. A bit ugly, but not more than +# usual autoconf stuff. +# m4_undefine([PLUGIN_NAME]) + + + + + + + + +if test "$ENABLE_WP" != "no"; then + + + + + USE_GUI=$USE_GUI" "wp + USED_WP=$USED_WP" "gui + + + + + + + + + + USE_RTE_ANNOTATION=$USE_RTE_ANNOTATION" "wp + USED_WP=$USED_WP" "rte_annotation + + + + + + + + USE_ALTERGO=$USE_ALTERGO" "wp + + + + + USE_COQ=$USE_COQ" "wp + + + + + USE_WHY=$USE_WHY" "wp + + + + + USE_DOT=$USE_DOT" "wp + + + + + USE_WHYDP=$USE_WHYDP" "wp + + + + # Why + + + + + + + + + + + for file in why; do + HAS_WHY= +# Extract the first word of "$file", so it can be a program name with args. +set dummy $file; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_prog_HAS_WHY+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$HAS_WHY"; then + ac_cv_prog_HAS_WHY="$HAS_WHY" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_HAS_WHY="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_HAS_WHY" && ac_cv_prog_HAS_WHY="no" +fi +fi +HAS_WHY=$ac_cv_prog_HAS_WHY +if test -n "$HAS_WHY"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HAS_WHY" >&5 +$as_echo "$HAS_WHY" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$HAS_WHY" = "yes"; then SELECTED_VAR=$file break; fi + done + + + + + + + + + + + + + # Why-dp + + + + + + + + + + + for file in why-dp; do + HAS_WHYDP= +# Extract the first word of "$file", so it can be a program name with args. +set dummy $file; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_prog_HAS_WHYDP+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$HAS_WHYDP"; then + ac_cv_prog_HAS_WHYDP="$HAS_WHYDP" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_HAS_WHYDP="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_HAS_WHYDP" && ac_cv_prog_HAS_WHYDP="no" +fi +fi +HAS_WHYDP=$ac_cv_prog_HAS_WHYDP +if test -n "$HAS_WHYDP"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HAS_WHYDP" >&5 +$as_echo "$HAS_WHYDP" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$HAS_WHYDP" = "yes"; then SELECTED_VAR=$file break; fi + done + + + + + + + + + + + + + # alt-ergo + + + + + + + + + + + for file in alt-ergo; do + HAS_ALTERGO= +# Extract the first word of "$file", so it can be a program name with args. +set dummy $file; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_prog_HAS_ALTERGO+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$HAS_ALTERGO"; then + ac_cv_prog_HAS_ALTERGO="$HAS_ALTERGO" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_HAS_ALTERGO="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_HAS_ALTERGO" && ac_cv_prog_HAS_ALTERGO="no" +fi +fi +HAS_ALTERGO=$ac_cv_prog_HAS_ALTERGO +if test -n "$HAS_ALTERGO"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HAS_ALTERGO" >&5 +$as_echo "$HAS_ALTERGO" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$HAS_ALTERGO" = "yes"; then SELECTED_VAR=$file break; fi + done + + + + + + + + + + + + + ALTERGO_VERSION=`alt-ergo -version | sed -e 's/Alt-Ergo $.$/\1/' ` + { $as_echo "$as_me:${as_lineno-$LINENO}: alt-ergo version is $ALTERGO_VERSION." >&5 +$as_echo "$as_me: alt-ergo version is $ALTERGO_VERSION." >&6;} + case $ALTERGO_VERSION in + 0.92.2) { $as_echo "$as_me:${as_lineno-$LINENO}: good." >&5 +$as_echo "$as_me: good." >&6;};; + ) { $as_echo "$as_me:${as_lineno-$LINENO}: alt-ergo's array theory unsupported." >&5 +$as_echo "$as_me: alt-ergo's array theory unsupported." >&6;};; + esac + + + # coq + + + + + + + + + + + for file in coqc; do + HAS_COQ= +# Extract the first word of "$file", so it can be a program name with args. +set dummy $file; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_prog_HAS_COQ+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$HAS_COQ"; then + ac_cv_prog_HAS_COQ="$HAS_COQ" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_HAS_COQ="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_HAS_COQ" && ac_cv_prog_HAS_COQ="no" +fi +fi +HAS_COQ=$ac_cv_prog_HAS_COQ +if test -n "$HAS_COQ"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HAS_COQ" >&5 +$as_echo "$HAS_COQ" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$HAS_COQ" = "yes"; then SELECTED_VAR=$file break; fi + done + + + + + + + + + + + + + + if test -n "$REQUIRE_WHY" -o -n "$USE_WHY" -o "$no" = "yes"; then + if test "$HAS_WHY" = "no"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: why not found" >&5 +$as_echo "$as_me: WARNING: why not found" >&2;} + reason="why missing" + for p in $REQUIRE_WHY; do + up=`upper "$p"` + ep=ENABLE_$up + eval enable_p=\$$ep + if test "$enable_p" != "no"; then + fp=FORCE_`upper "$p"` + if eval test "\$$fp" = "yes"; then + as_fn_error "$p requested but $reason." "$LINENO" 5 + fi + eval $ep="no\ $see\ warning\ about\ why$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p disabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + for p in $USE_WHY; do + up=`upper "$p"` + ep=ENABLE_$up + eval eep="\$$ep" + if test "`echo $eep | sed -e 's/ .//' `" != "no"; then + eval $ep="partial\ $see\ warning\ about\ why$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p partially enabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + else + WHY=why + fi + fi + + if test -n "$REQUIRE_WHYDP" -o -n "$USE_WHYDP" -o "$no" = "yes"; then + if test "$HAS_WHYDP" = "no"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: why-dp not found" >&5 +$as_echo "$as_me: WARNING: why-dp not found" >&2;} + reason="why-dp missing" + for p in $REQUIRE_WHYDP; do + up=`upper "$p"` + ep=ENABLE_$up + eval enable_p=\$$ep + if test "$enable_p" != "no"; then + fp=FORCE_`upper "$p"` + if eval test "\$$fp" = "yes"; then + as_fn_error "$p requested but $reason." "$LINENO" 5 + fi + eval $ep="no\ $see\ warning\ about\ why-dp$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p disabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + for p in $USE_WHYDP; do + up=`upper "$p"` + ep=ENABLE_$up + eval eep="\$$ep" + if test "`echo $eep | sed -e 's/ .//' `" != "no"; then + eval $ep="partial\ $see\ warning\ about\ why-dp$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p partially enabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + else + WHYDP=why-dp + fi + fi + + if test -n "$REQUIRE_ALTERGO" -o -n "$USE_ALTERGO" -o "$no" = "yes"; then + if test "$HAS_ALTERGO" = "no"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: alt-ergo not found" >&5 +$as_echo "$as_me: WARNING: alt-ergo not found" >&2;} + reason="alt-ergo missing" + for p in $REQUIRE_ALTERGO; do + up=`upper "$p"` + ep=ENABLE_$up + eval enable_p=\$$ep + if test "$enable_p" != "no"; then + fp=FORCE_`upper "$p"` + if eval test "\$$fp" = "yes"; then + as_fn_error "$p requested but $reason." "$LINENO" 5 + fi + eval $ep="no\ $see\ warning\ about\ alt-ergo$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p disabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + for p in $USE_ALTERGO; do + up=`upper "$p"` + ep=ENABLE_$up + eval eep="\$$ep" + if test "`echo $eep | sed -e 's/ .//' `" != "no"; then + eval $ep="partial\ $see\ warning\ about\ alt-ergo$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p partially enabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + else + ALTERGO=alt-ergo + fi + fi + + if test -n "$REQUIRE_COQ" -o -n "$USE_COQ" -o "$no" = "yes"; then + if test "$HAS_COQ" = "no"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: coq not found" >&5 +$as_echo "$as_me: WARNING: coq not found" >&2;} + reason="coqc missing" + for p in $REQUIRE_COQ; do + up=`upper "$p"` + ep=ENABLE_$up + eval enable_p=\$$ep + if test "$enable_p" != "no"; then + fp=FORCE_`upper "$p"` + if eval test "\$$fp" = "yes"; then + as_fn_error "$p requested but $reason." "$LINENO" 5 + fi + eval $ep="no\ $see\ warning\ about\ coqc$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p disabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p disabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + for p in $USE_COQ; do + up=`upper "$p"` + ep=ENABLE_$up + eval eep="\$$ep" + if test "`echo $eep | sed -e 's/ .//' `" != "no"; then + eval $ep="partial\ $see\ warning\ about\ coqc$" + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $p partially enabled because $reason." >&5 +$as_echo "$as_me: WARNING: $p partially enabled because $reason." >&2;} + eval INFO_$up=\", $reason\" + fi + done + else + COQ=coqc + fi + fi + + +# First, initialize some variables +for fp in ${PLUGINS_FORCE_LIST}; do + if test "$fp" != "FORCE_GTKSOURCEVIEW"; then + plugin=`echo $fp | sed -e "s/FORCE_$.$/\1/" ` + TODOLIST=$TODOLIST" "$plugin + eval MARK_$plugin= + eval REMEMBER_$plugin= + fi +done +# main call +compute_dependency + +fi + + + + + ac_config_files="$ac_config_files ./Makefile" + + + + +# Compute INFO_ and exported ENABLE_ from previously computed ENABLE_* + for fp in ${PLUGINS_FORCE_LIST}; do + if test "$fp" != "FORCE_GTKSOURCEVIEW"; then + plugin=`echo $fp | sed -e "s/FORCE_$.$/\1/" ` + ep=ENABLE_$plugin + eval v=\$$ep + eval ep_v=`echo $v | sed -e 's/ .//' ` + eval ENABLE_$plugin=$ep_v + reason=`echo $v | sed -e 's/[a-z]$ .$/\1/' ` + n=NAME_$plugin + eval name=\$$n + info= + if test "$reason" != "$ep_v"; then + info=$reason + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: $name: $ep_v$info" >&5 +$as_echo "$as_me: $name: $ep_v$info" >&6;} + fi + done + 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 + test "x$cache_file" != "x/dev/null" && + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + cat confcache >$cache_file + 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= +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. +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 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=$?; test $as_status -eq 0 && as_status=1 + if test "$3"; then + as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 + fi + $as_echo "$as_me: error: $1" >&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 -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -p' + fi +else + as_ln_s='cp -p' +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 + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in #( + -)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( + ???[sx]):;;)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# 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.65. 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.65, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2009 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=$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"` ;; + 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") CONFIG_FILES="$CONFIG_FILES ./Makefile" ;; + + ) 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= + trap 'exit_status=$? + { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$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 -n "$tmp" && test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 + +# 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 2>/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 {' >"$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 >>"\$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 +' <conf$$subs.awk | sed ' +/^[^""]/{ + N + s/\n// +} +' >>$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$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 < "$tmp/subs1.awk" > "$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 $(srcdir), +# ${srcdir} and @srcdir@ 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[ ]=/{ +s/:\$(srcdir):/:/ +s/:\${srcdir}:/:/ +s/:@srcdir@:/:/ +s/^$[^=]=[ ]$:/\1/ +s/:$// +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="$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 "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 >"$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 "$tmp/subs.awk" >$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' "$tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]datarootdir[ ]:=/p' "$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 "$tmp/stdin" + case $ac_file in + -) cat "$tmp/out" && rm -f "$tmp/out";; + ) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; + esac \ + || as_fn_error "could not create $ac_file" "$LINENO" 5 + ;; + + + + esac + + + case $ac_file$ac_mode in + "./Makefile":F) chmod -w ./Makefile ;; + + 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 $? +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 + + + + + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/configure.ac frama-c-20111001+nitrogen+dfsg/src/wp/configure.ac --- frama-c-20110201+carbon+dfsg/src/wp/configure.ac 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/configure.ac 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,72 @@ +########################################################################## +# # +# This file is part of WP plug-in of Frama-C. # +# # +# Copyright (C) 2007-2011 # +# CEA (Commissariat a l'�nergie atomique et aux �nergies # +# alternatives) # +# # +# you can redistribute it and/or modify it under the terms of the GNU # +# Lesser General Public License as published by the Free Software # +# Foundation, version 2.1. # +# # +# It 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 Lesser General Public License for more details. # +# # +# See the GNU Lesser General Public License version 2.1 # +# for more details (enclosed in the file licenses/LGPLv2.1). # +# # +########################################################################## + +m4_define([plugin_file],Makefile.in) + +m4_define([FRAMAC_SHARE_ENV], + [m4_normalize(m4_esyscmd([echo $FRAMAC_SHARE]))]) + +m4_define([FRAMAC_SHARE], + [m4_ifval(FRAMAC_SHARE_ENV,[FRAMAC_SHARE_ENV], + [m4_esyscmd(frama-c -print-path)])]) + +m4_ifndef([FRAMAC_M4_MACROS], + [m4_include(FRAMAC_SHARE/configure.ac)] + ) + +check_plugin(wp,PLUGIN_RELATIVE_PATH(plugin_file),[support for wp plug-in],yes,yes) + +if test "$ENABLE_WP" != "no"; then + plugin_use(wp,gui) + plugin_use(wp,rte_annotation) + plugin_use_external(wp,altergo) + plugin_use_external(wp,coq) + plugin_use_external(wp,why) + plugin_use_external(wp,dot) + plugin_use_external(wp,whydp) + + # Why + configure_tool([WHY],[why],[why not found],no) + + # Why-dp + configure_tool([WHYDP],[why-dp],[why-dp not found],no) + + # alt-ergo + configure_tool([ALTERGO],[alt-ergo],[alt-ergo not found],no) + + ALTERGO_VERSION=`alt-ergo -version | sed -e 's/Alt-Ergo $.$/\1/' ` + AC_MSG_NOTICE([alt-ergo version is $ALTERGO_VERSION.]) + case $ALTERGO_VERSION in + 0.92.2) AC_MSG_NOTICE([good.]);; + ) AC_MSG_NOTICE([alt-ergo's array theory unsupported.]);; + esac + + + # coq + configure_tool([COQ],[coqc],[coq not found],no) + + check_plugin_dependencies +fi + +write_plugin_config(Makefile) + +AC_SUBST(ALTERGO_VERSION) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/ctypes.ml frama-c-20111001+nitrogen+dfsg/src/wp/ctypes.ml --- frama-c-20110201+carbon+dfsg/src/wp/ctypes.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/ctypes.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,472 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- C-Types --- ) +( -------------------------------------------------------------------------- ) + +open Cil_types +open Cil_datatype + +module WpLog = Wp_parameters + +type c_int = + | UInt8 + | SInt8 + | UInt16 + | SInt16 + | UInt32 + | SInt32 + | UInt64 + | SInt64 + +let compare_c_int : c_int -> c_int -> _ = Extlib.compare_basic + +let signed = function + | UInt8 | UInt16 | UInt32 | UInt64 -> false + | SInt8 | SInt16 | SInt32 | SInt64 -> true + +let i_sizeof = function + | UInt8 | SInt8 -> 8 + | UInt16 | SInt16 -> 16 + | UInt32 | SInt32 -> 32 + | UInt64 | SInt64 -> 64 + +let make_c_int signed = function + | 1 -> if signed then SInt8 else UInt8 + | 2 -> if signed then SInt16 else UInt16 + | 4 -> if signed then SInt32 else UInt32 + | 8 -> if signed then SInt64 else UInt64 + | size -> WpLog.not_yet_implemented "%d-bits integers" size + +let c_int ikind = + let mach = Cil.theMachine.Cil.theMachine in + match ikind with + | IBool -> make_c_int false mach.sizeof_int + | IChar -> if mach.char_is_unsigned then UInt8 else SInt8 + | ISChar -> SInt8 + | IUChar -> UInt8 + | IInt -> make_c_int true mach.sizeof_int + | IUInt -> make_c_int false mach.sizeof_int + | IShort -> make_c_int true mach.sizeof_short + | IUShort -> make_c_int false mach.sizeof_short + | ILong -> make_c_int true mach.sizeof_long + | IULong -> make_c_int false mach.sizeof_long + | ILongLong -> make_c_int true mach.sizeof_longlong + | IULongLong -> make_c_int false mach.sizeof_longlong + +( Bounds of an integer according to c_int ti : + An integer i : i \in [c_int_bounds ti] if + [c_int_bounds ti] = (min,max) then min <=i<max.) +let c_int_bounds = function + | UInt8 -> (Big_int.zero_big_int,Big_int.big_int_of_string "256") + | SInt8 -> (Big_int.big_int_of_string "-128", + Big_int.big_int_of_string "128") + | UInt16 -> (Big_int.zero_big_int, + Big_int.big_int_of_string "65536") + | SInt16 -> (Big_int.big_int_of_string "-32768", + Big_int.big_int_of_string "32768") + | UInt32 -> (Big_int.zero_big_int, + Big_int.big_int_of_string "4294967296") + | SInt32 -> (Big_int.big_int_of_string "-2147483648" , + Big_int.big_int_of_string "2147483648" ) + | UInt64 -> (Big_int.zero_big_int , + Big_int.big_int_of_string "18446744073709551616" ) + | SInt64 -> (Big_int.big_int_of_string "-9223372036854775808" , + Big_int.big_int_of_string "9223372036854775808" ) + +let c_int_all = + [ UInt8 ; SInt8 ; UInt16 ; SInt16 ; UInt32 ; SInt32 ; UInt64 ; SInt64 ] + +let c_bool () = c_int IInt +let c_char () = c_int IChar +let c_ptr () = + make_c_int false Cil.theMachine.Cil.theMachine.sizeof_ptr + +let sub_c_int t1 t2 = + if (signed t1 = signed t2) then i_sizeof t1 <= i_sizeof t2 + else (not(signed t1) && (i_sizeof t1 < i_sizeof t2)) + + +type c_float = + | Float16 + | Float32 + | Float64 + | Float96 + | Float128 + +let compare_c_float : c_float -> c_float -> _ = Extlib.compare_basic + +let f_sizeof = function + | Float16 -> 16 + | Float32 -> 32 + | Float64 -> 64 + | Float96 -> 96 + | Float128 -> 128 + +let make_c_float = function + | 2 -> Float16 + | 4 -> Float32 + | 8 -> Float64 + | 12 -> Float96 + | 16 -> Float128 + | size -> WpLog.not_yet_implemented "%d-bits floats" size + +let c_float fkind = + let mach = Cil.theMachine.Cil.theMachine in + match fkind with + | FFloat -> make_c_float mach.sizeof_float + | FDouble -> make_c_float mach.sizeof_double + | FLongDouble -> make_c_float mach.sizeof_longdouble + +let sub_c_float f1 f2 = f_sizeof f1 <= f_sizeof f2 + +( Array objects, with both the head view and the flatten view. ) + +type arrayflat = { + arr_size : int64; ( number of elements in the array ) + arr_dim : int ; ( number of dimensions in the array ) + arr_cell : typ ; ( type of elementary cells of the flatten array ) + arr_cell_nbr : int64 ; ( number of elementary cells in the flatten array ) +} + +type arrayinfo = { + arr_element : typ ; ( type of the elements of the array ) + arr_flat : arrayflat option; +} + +( Type of variable, inits, field or assignable values. ) +type c_object = + | C_int of c_int + | C_float of c_float + | C_pointer of typ + | C_comp of compinfo + | C_array of arrayinfo + +( -------------------------------------------------------------------------- ) +( --- Memoization --- ) +( -------------------------------------------------------------------------- ) + +let idx = function + | UInt8 -> 0 + | SInt8 -> 1 + | UInt16 -> 2 + | SInt16 -> 3 + | UInt32 -> 4 + | SInt32 -> 5 + | UInt64 -> 6 + | SInt64 -> 7 + +let imemo f = + let m = Array.create 8 None in + fun i -> + let k = idx i in + match m.(k) with + | Some r -> r + | None -> + let r = f i in m.(k) <- Some r ; r + +let fdx = function + | Float16 -> 0 + | Float32 -> 1 + | Float64 -> 2 + | Float96 -> 3 + | Float128 -> 4 + +let fmemo f = + let m = Array.create 8 None in + fun z -> + let k = fdx z in + match m.(k) with + | Some r -> r + | None -> + let r = f z in m.(k) <- Some r ; r + +( -------------------------------------------------------------------------- ) +( --- Pretty Printers --- ) +( -------------------------------------------------------------------------- ) + +let pp_int fmt i = Format.fprintf fmt "%cint%d" + (if signed i then 's' else 'u') (i_sizeof i) + +let pp_float fmt f = Format.fprintf fmt "float%d" (f_sizeof f) + +let pp_object fmt = function + | C_int i -> pp_int fmt i + | C_float f -> pp_float fmt f + | C_pointer _ -> Format.pp_print_string fmt "obj-pointer" + | C_comp _ -> Format.pp_print_string fmt "obj-struct/union" + | C_array _ -> Format.pp_print_string fmt "obj-array" + +( -------------------------------------------------------------------------- ) +( --- Array Info --- ) +( -------------------------------------------------------------------------- ) + +let char c = + match Cil.charConstToInt c with + | CInt64(k,_,_) -> My_bigint.to_int64 k + | _ -> WpLog.fatal "char-const-to-int" + +let constant e = + match (Cil.constFold true e).enode with + | Const(CInt64(k,_,_)) -> My_bigint.to_int64 k + | Const(CChr c) -> char c + | _ -> WpLog.fatal "Non-constant expression (%a)" !Ast_printer.d_exp e + +let get_int e = + match (Cil.constFold true e).enode with + | Const(CInt64(k,_,_)) -> Some (My_bigint.to_int64 k) + | Const(CChr c) -> Some (char c) + | _ -> None + +let dimension t = + let rec flat k d = function + | TNamed _ as t -> flat k d (Cil.unrollType t) + | TArray(ty,Some e,_,_) -> + flat (succ k) (Int64.mul d (constant e)) ty + | te -> k , d , te + in flat 1 Int64.one t + +( -------------------------------------------------------------------------- ) +( --- Value State_builder. --- ) +( -------------------------------------------------------------------------- ) + +let is_void typ = + match Cil.unrollType typ with + | TVoid _ -> true + | _ -> false + +let object_of typ = + match Cil.unrollType typ with + | TInt(i,_) -> C_int (c_int i) + | TFloat(f,_) -> C_float (c_float f) + | TPtr(typ,_) -> + begin + match Cil.unrollType typ with + | TVoid _ -> C_pointer (TInt (IChar,[])) + | _ -> C_pointer typ + end + | TFun _ as t -> C_pointer t + | TEnum ({ekind=i},_) -> C_int (c_int i) + | TComp (comp,_,_) -> C_comp comp + | TArray (typ_elt,e_opt,_,_) -> + begin + match e_opt with + | None -> + C_array { + arr_element = typ_elt; + arr_flat = None; + } + + | Some e -> + let dim,ncells,ty_cell = dimension typ in + C_array { + arr_element = typ_elt ; + arr_flat = Some { + arr_size = constant e ; + arr_dim = dim ; + arr_cell = ty_cell ; + arr_cell_nbr = ncells ; + } + } + end + | TBuiltin_va_list _ -> + WpLog.not_yet_implemented "valiadyc type" + | TVoid _ -> + WpLog.fatal ~current:true "void object" + | TNamed _ -> + WpLog.fatal "non-unrolled named type (%a)" !Ast_printer.d_type typ + +let object_of_pointed = function + C_int _ | C_float _ | C_comp _ as o -> + Wp_parameters.fatal + "object_of_pointed called on non-pointer %a@." pp_object o + | C_array info -> object_of info.arr_element + | C_pointer typ -> object_of typ + + +let object_of_array_elem = function + | C_array arr -> object_of arr.arr_element + | o -> Wp_parameters.fatal + "object_of_array_elem called on non-array %a." pp_object o + +let no_infinite_array = function + | C_array {arr_flat = None} -> false + | _ -> true + +let array_dim arr = + match arr.arr_flat with + | Some f -> object_of f.arr_cell , f.arr_dim - 1 + | None -> + let rec collect_dim arr n = + match object_of arr.arr_element with + | C_array arr -> collect_dim arr (succ n) + | te -> te,n + in collect_dim arr 1 + +let int64_max a b = + if Int64.compare a b < 0 then b else a + +let rec sizeof_object = function + | C_int i -> Int64.of_int (i_sizeof i) + | C_float f -> Int64.of_int (f_sizeof f) + | C_pointer _ty -> Int64.of_int (i_sizeof (c_ptr())) + | C_comp cinfo -> + let merge = if cinfo.cstruct then Int64.add else int64_max in + List.fold_left + (fun sz f -> merge sz (sizeof_object (object_of f.ftype))) + Int64.zero cinfo.cfields + | C_array ainfo -> + begin + match ainfo.arr_flat with + | Some a -> Int64.mul + (sizeof_object(object_of a.arr_cell)) a.arr_cell_nbr + | None -> WpLog.not_yet_implemented "Sizeof unknown-size array" + end + +let field_offset f = + let rec acc ofs f = function + | [] -> Wp_parameters.fatal "[field_offset] not found field %s" f.fname ; + | fi::m -> + if Cil_datatype.Fieldinfo.equal f fi then ofs else + let sf = sizeof_object (object_of fi.ftype) in + acc (Int64.add ofs sf) f m + in acc Int64.zero f f.fcomp.cfields + +( Conforms to @ C-ISO � 6.3.1.8 ) +( If same sign => greater rank. ) +( If different: ) +( Case 1: ) +( rank(unsigned) >= rank(signed) ) +( then convert to unsigned ) +( Case 2: ) +( domain(unsigend) contains ) +( domain(signed) ) +( then convert to signed ) +( Otherwise: ) +( both are converted to unsiged ) +( ) +( Case 2 is actually the negative ) +( of Case 1, and both simplifies ) +( into converting to the operand ) +( with greater rank, whatever ) +( their sign. ) + +let i_convert t1 t2 = if i_sizeof t1 < i_sizeof t2 then t2 else t1 +let f_convert t1 t2 = if f_sizeof t1 < f_sizeof t2 then t2 else t1 + +let promote a1 a2 = + match a1 , a2 with + | C_int i1 , C_int i2 -> C_int (i_convert i1 i2) + | C_float f1 , C_float f2 -> C_float (f_convert f1 f2) + | C_int _ , C_float _ -> a2 + | C_float _ , C_int _ -> a1 + | _ -> WpLog.not_yet_implemented + "promotion between arithmetics and pointer types" + +( ------------------------------------------------------------------------ ) +( --- Comparable --- ) +( ------------------------------------------------------------------------ ) + +module AinfoComparable = struct + type t = arrayinfo + let hash a = Typ.hash a.arr_element + let equal a b = + Typ.equal a.arr_element b.arr_element && + (match a.arr_flat , b.arr_flat with + | Some a , Some b -> Int64.compare a.arr_size b.arr_size = 0 + | None , None -> true + | _ -> false) + let compare a b = + let c = Typ.compare a.arr_element b.arr_element in + if c <> 0 then c + else match a.arr_flat , b.arr_flat with + | Some a , Some b -> Int64.compare a.arr_size b.arr_size + | None , Some _ -> (-1) + | Some _ , None -> 1 + | None , None -> 0 +end + +let hash = function + | C_int _ -> 3 + | C_float _ -> 5 + | C_pointer _ -> 7 + | C_comp c -> 11 Compinfo.hash c + | C_array a -> 13 * AinfoComparable.hash a + +let equal a b = + match a,b with + | C_int i, C_int i' -> i=i' + | C_float f , C_float f' -> f=f' + | C_pointer te , C_pointer te' -> Typ.equal te te' + | C_comp c , C_comp c' -> Compinfo.equal c c' + | C_array a , C_array a' -> AinfoComparable.equal a a' + | _ -> false + +let basetype = function + | C_int _ -> 1 + | C_float _ -> 2 + | C_pointer _ -> 3 + | C_comp c -> if c.cstruct then 4 else 5 + | C_array _ -> Wp_parameters.fatal "[basetype] of an array" + +let compare a b = + match a,b with + | C_int i, C_int i' -> compare_c_int i i' + | C_float f , C_float f' -> compare_c_float f f' + | C_pointer te , C_pointer te' -> Typ.compare te te' + | C_comp c , C_comp c' -> Compinfo.compare c c' + | C_array a , C_array a' -> AinfoComparable.compare a a' + | _ -> + let k1 = basetype a in + let k2 = basetype b in + assert (k1<>k2) ; + k1 - k2 + +let rec basename = function + | C_int i -> Pretty_utils.sfprintf "%a" pp_int i + | C_float f -> Pretty_utils.sfprintf "%a" pp_float f + | C_pointer _ -> "pointer" + | C_comp c -> c.cname + | C_array a -> + let te = basename (object_of a.arr_element) in + match a.arr_flat with + | None -> te ^ "_array" + | Some f -> te ^ "_" ^ Int64.to_string f.arr_size + +let rec pretty fmt = function + | C_int i -> pp_int fmt i + | C_float f -> pp_float fmt f + | C_pointer _ -> Format.pp_print_string fmt "pointer" + | C_comp c -> Format.pp_print_string fmt c.cname + | C_array a -> + let te = object_of a.arr_element in + match a.arr_flat with + | None -> Format.fprintf fmt "%a[]" pretty te + | Some f -> Format.fprintf fmt "%a[%s]" pretty te + (Int64.to_string f.arr_size) + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/ctypes.mli frama-c-20111001+nitrogen+dfsg/src/wp/ctypes.mli --- frama-c-20110201+carbon+dfsg/src/wp/ctypes.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/ctypes.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,140 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** C-Types ) +( -------------------------------------------------------------------------- *) + +open Cil_types + +(** Runtime integers. *) +type c_int = + | UInt8 + | SInt8 + | UInt16 + | SInt16 + | UInt32 + | SInt32 + | UInt64 + | SInt64 + +val c_int_all : c_int list + +(** Runtime floats. *) +type c_float = + | Float16 + | Float32 + | Float64 + | Float96 + | Float128 + +(** Array objects, with both the head view and the flatten view. *) +type arrayflat = { + arr_size : int64 ; (** number of elements in the array *) + arr_dim : int ; (** number of dimensions in the array *) + arr_cell : typ ; (** type of elementary cells of the flatten array. Never an array. *) + arr_cell_nbr : int64 ; (** number of elementary cells in the flatten array *) +} + +type arrayinfo = { + arr_element : typ ; (** type of the elements of the array *) + arr_flat : arrayflat option; +} + +(** Type of variable, inits, field or assignable values. *) +type c_object = + | C_int of c_int + | C_float of c_float + | C_pointer of typ + | C_comp of compinfo + | C_array of arrayinfo + +(** c_objects of elements pointed to by pointer or array. fatal error + if called on other type. +*) +val object_of_pointed: c_object -> c_object + +val object_of_array_elem : c_object -> c_object +(** {2 Utilities} *) + +val imemo : (c_int -> 'a) -> c_int -> 'a +val fmemo : (c_float -> 'a) -> c_float -> 'a + +val c_char : unit -> c_int (** Returns the type of [char] *) +val c_bool : unit -> c_int (** Returns the type of [int] *) +val c_ptr : unit -> c_int (** Returns the type of pointers *) + +val c_int : ikind -> c_int (** Conforms to {Cil.theMachine} *) +val c_float : fkind -> c_float (** Conforms to {Cil.theMachine} *) +val object_of : typ -> c_object + +val is_void : typ -> bool + +val char : char -> int64 +val constant : exp -> int64 +val get_int : exp -> int64 option + +val signed : c_int -> bool (** true if ikind is signed ) +val c_int_bounds: c_int -> Big_int.big_int Big_int.big_int + +(** All sizes are in bits ) +val i_sizeof : c_int -> int + +val f_sizeof : c_float -> int + +val sub_c_int: c_int -> c_int -> bool + +val sub_c_float : c_float -> c_float -> bool + +val sizeof_object: c_object -> int64 +val field_offset : fieldinfo -> int64 + +val no_infinite_array : c_object -> bool +val array_dim : arrayinfo -> c_object int + +val i_convert : c_int -> c_int -> c_int +val f_convert : c_float -> c_float -> c_float +val promote : c_object -> c_object -> c_object + +val pp_int : Format.formatter -> c_int -> unit +val pp_float : Format.formatter -> c_float -> unit +val pp_object : Format.formatter -> c_object -> unit + +val basename : c_object -> string +val compare : c_object -> c_object -> int +val equal : c_object -> c_object -> bool +val hash : c_object -> int +val pretty : Format.formatter -> c_object -> unit + +module AinfoComparable : +sig + type t = arrayinfo + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/datalib.ml frama-c-20111001+nitrogen+dfsg/src/wp/datalib.ml --- frama-c-20110201+carbon+dfsg/src/wp/datalib.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/datalib.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,908 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +module WpLog = Wp_parameters +open Format +open Ctypes +open Cil_types +open Formula + +(* ------------------------------------------------------------------------ ) +( --- Goals information collection --- ) +( ------------------------------------------------------------------------ ) + +module Collector = +struct + + type t = { + mutable c_warning : Wpo.warning list; + mutable c_depends : Property.t list; + } + + let stack = ref [] + + let push () = + let c = { c_warning = []; c_depends = [] } in + stack := c::(!stack) ; c + + let pop c = match !stack with + | top::tl when top == c -> + stack := tl; (List.rev c.c_warning, List.rev c.c_depends) + | _ -> Wp_parameters.fatal "Datalib.Collector: inconsistent stack" + + let add_warning ?(severe=false) ?source ~reason effect = + let f _ = + let msg = Format.flush_str_formatter () in + let wrn = { + Wpo.wrn_loc = Log.get_current_source () ; + Wpo.wrn_severe = severe ; + Wpo.wrn_source = (match source with None -> "wp" | Some r -> r) ; + Wpo.wrn_reason = reason ; + Wpo.wrn_effect = msg ; + } in + match !stack with + | top::_ -> top.c_warning <- wrn::top.c_warning + | _ -> Wp_parameters.fatal "Datalib.Collector: empty stack" + in Format.kfprintf f Format.str_formatter effect + + let add_depend pid = + match !stack with + | top::_ -> top.c_depends <- pid::top.c_depends + | _ -> Wp_parameters.fatal "Datalib.Collector: empty stack" + +end + +module Create (V:Mvalues.Values) : Formula.Logic with module F = V.F = +struct + + module F = V.F + + ( ------------------------------------------------------------------------ ) + ( --- Acsl Types Guards Generations --- ) + ( ------------------------------------------------------------------------ ) + + let has_type_rec = ref (fun (_:F.abstract) _ -> assert false) + let has_obj_rec = ref (fun (_:F.abstract) _ -> assert false) + + module IsComp = F.DRegister + (struct + include F.Compinfo + let prefix = "Is" + let section = S_Logic_Def + let clear () = () + let pp_title fmt x = Format.fprintf fmt "Type constraint for %a" + F.Compinfo.pp_title x + let declare compinfo _ = + let pool = F.pool () in + let x = F.p_fresh pool "x" (Model(Record compinfo)) in + let vx = F.var x in + let has_type_fd f = !has_type_rec (F.acc_field vx f) (Ctype f.ftype) in + let def = F.p_conj (List.map has_type_fd compinfo.cfields) in + PredicateDef([x],def) + end) + + let rec is_array_dim pool a te n = + if n > 0 then + let i = F.p_fresh pool "i" (Model Formula.Integer) in + let a_i = F.acc_index (F.unwrap a) (F.var i) in + F.p_forall [i] (is_array_dim pool a_i te (pred n)) + else !has_obj_rec a te + + module IsArray = F.DRegister + (struct + include F.ArrayDim + let prefix = "IsArray" + let section = S_Logic_Def + let clear () = () + let pp_title fmt x = Format.fprintf fmt "Type constraint for %a" + F.ArrayDim.pp_title x + let declare (te,n) _ = + let pool = F.pool () in + let a = F.p_fresh pool "a" (Model(V.tau_of_object_array te n)) in + PredicateDef([a],is_array_dim pool (F.var a) te n) + end) + + let has_type_int i e = F.guard i e + + let is_comp comp e = F.p_app1 (IsComp.get_definition comp).d_name e + let is_array arr e = + let adim = Ctypes.array_dim arr in + F.p_app1 (IsArray.get_definition adim).d_name e + + + let has_obj e = function + | C_int i -> has_type_int i (F.unwrap e) + | C_float _ -> F.p_true + | C_pointer _ -> F.p_true + | C_array arr -> is_array arr e + | C_comp comp -> is_comp comp e + + let has_type e = function + | Ctype ty -> has_obj e (object_of ty) + | (Ltype _ | Linteger | Lreal | Lvar _ | Larrow _ ) -> F.p_true + + let () = has_type_rec := has_type + let () = has_obj_rec := has_obj + + ( ------------------------------------------------------------------------ ) + ( --- Constrained Terms --- ) + ( ------------------------------------------------------------------------ ) + + type bindings = binding list and binding = + | Forall of F.var list + | Exists of F.var list + | Any of F.var F.pred + | Let of F.var * F.abstract + + let pp_binding fmt = function + | Forall xs -> Format.fprintf fmt "Forall @[%a@]" (Pretty_utils.pp_list F.pp_var) xs + | Exists xs -> Format.fprintf fmt "Exists @[%a@]" (Pretty_utils.pp_list F.pp_var) xs + | Any(x,p) -> Format.fprintf fmt "Any %a s.t. @[%a@]" F.pp_var x F.pp_pred p + | Let(x,t) -> Format.fprintf fmt "Let %a = @[%a@]" F.pp_var x F.pp_term t + + type context = { + pool : F.pool ; + mutable bindings : bindings ; + } + + let closed : bindings = [] + let context = ref [] + + let occur_check y xs = + if List.exists (F.eq_var y) xs then + Wp_parameters.fatal + "Quantification of constrained variable" + + let pp_vkind fmt = function + | Formula.Model t -> F.pp_tau fmt t + | Formula.Acsl (_t,ty) -> !Ast_printer.d_logic_type fmt ty + + let guards_with f xs p = + let do_with f p x = + match F.kind_of_var x with + | Model _ -> p + | Acsl (_,ty) -> f (has_type (F.var x) ty) p + + in + List.fold_left (do_with f) xs p + + let sub y xs = List.filter (fun x -> not (F.eq_var x y)) xs + + let some_alpha pool x = Some(F.p_freshen pool x) + + let rec apply_bindings alpha bindings p = + match bindings with + | [] -> p + | b::bindings -> + let p = apply_bindings alpha bindings p in + match b with + | Forall xs -> F.p_forall xs p + | Exists xs -> F.p_exists xs p + | Any(x,q) -> F.p_forall [x] (F.p_implies q p) + | Let(x,t) -> F.p_subst alpha x t p + + let alpha x = + match !context with + | [] -> None + | c::_ -> Some(F.p_freshen c.pool x) + + let do_subst x v p = + if F.pred_has_var [x] p + then F.p_subst alpha x v p + else p + + let do_forall xs p = + if F.pred_has_var xs p + then + let ys = List.filter (fun y -> F.pred_has_var [y] p) xs in + if ys = [] then p + else + F.p_forall ys (guards_with F.p_implies p ys) + else p + + let do_exists xs p = + if F.pred_has_var xs p + then + let ys = List.filter (fun y -> F.pred_has_var [y] p) xs in + if ys = [] then p + else F.p_exists ys (guards_with F.p_and p ys) + else p + + let rec has_var xs bindings = + xs <> [] && + match bindings with + | [] -> false + | b::others -> + match b with + | Forall ys | Exists ys -> + let xs = List.fold_right sub ys xs in + has_var xs others + | Any(y,p) -> + F.pred_has_var xs p || has_var (sub y xs) others + | Let(y,t) -> + F.term_has_var xs t || has_var (sub y xs) others + + let forall xs p = + match !context with + | [] -> do_forall xs p + | c :: _ -> + if has_var xs c.bindings + then ( c.bindings <- Forall xs :: c.bindings ; p ) + else do_forall xs p + + let exists xs p = + match !context with + | [] -> do_exists xs p + | c :: _ -> + if has_var xs c.bindings + then ( c.bindings <- Exists xs :: c.bindings ; p ) + else do_exists xs p + + let fresh id vk = + match !context with + | [] -> + Wp_parameters.fatal "Bad context (for %S:%a)" id pp_vkind vk + | c::_ -> + F.p_fresh c.pool id + (match vk with + | Formula.Model t -> Model t + | Formula.Acsl (t,ty) -> Acsl (t,ty) + ) + + let pool () = + match !context with + | [] -> Wp_parameters.fatal "Bad context (no pool available)" + | c::_ -> c.pool + + let vkind_of_var x = + match F.kind_of_var x with + | Model t -> Formula.Model t + | Acsl(t,c) -> Formula.Acsl (t,c) + + let term_such_that tau phi = + match !context with + | [] -> Wp_parameters.fatal "No context opened for constraints" + | c::_ -> + let x = F.p_fresh c.pool "X" (Model tau) in + let t = F.var x in + c.bindings <- Any(x,phi t) :: c.bindings ; t + + let subst_in_bindings c x v p = + if has_var [x] c.bindings + then ( c.bindings <- Let(x,v) :: c.bindings ; p ) + else ( do_subst x v p ) + + let subst x v p = + match !context with + | [] -> do_subst x v p + | c::_ -> subst_in_bindings c x (F.wrap v) p + + let close bindings p = + apply_bindings (fun _ -> None) bindings p + + let has_context_vars xs p = + F.pred_has_var xs p || + ( match !context with + | [] -> false + | c::_ -> has_var xs c.bindings ) + + (* -------------------------------------------------------------------------- ) + ( --- Context Management --- ) + ( -------------------------------------------------------------------------- ) + + let push where pool bindings = + Wp_parameters.debug ~dkey:"context" "PUSH %d: %S@." (List.length !context) where ; + let c = { pool=pool ; bindings=bindings } in + context := c :: !context ; c + + let pop where c0 = + Wp_parameters.debug ~dkey:"context" "POPK %d: %S@." (pred (List.length !context)) where ; + match !context with + | [] -> Wp_parameters.fatal "No context for constrained term" + | c::stack -> + if not (c0 == c) + then Wp_parameters.fatal "Context mismatch for constrained term" ; + context := stack ; + c.bindings + + let flush where c0 p = + Wp_parameters.debug ~dkey:"context" "FLUSH %d %S@." (pred (List.length !context)) where ; + match !context with + | [] -> Wp_parameters.fatal "No context for constrained term" + | c::stack -> + if not (c0 == c) + then Wp_parameters.fatal "Context mismatch for constrained term" ; + context := stack ; + apply_bindings (some_alpha c.pool) c.bindings p + + let kill where c = ignore (pop where c) + + ( ------------------------------------------------------------------------ ) + ( --- Generalized Substitutions --- ) + ( ------------------------------------------------------------------------ ) + + + let pp_sigma fmt s = + begin + Format.fprintf fmt "[" ; + List.iter (fun (x,x') -> Format.fprintf fmt " %a:=%a" F.pp_var x F.pp_var x') s ; + Format.fprintf fmt " ]" ; + end + + let pp_bindings fmt xts = + List.iter (fun (x,t) -> Format.fprintf fmt "%a:= %a@\n" F.pp_var x F.pp_term t) xts + + + let freshen x = + match !context with + | [] -> Wp_parameters.fatal "no context opened for havoc" + | c::_ -> F.p_freshen c.pool x + + let apply = F.e_rename + + let rec domain xs d = function + | [] -> List.rev xs,List.rev d + | h::hs -> + match h with + | F.Fresh x -> domain (x::xs) d hs + | F.Update(x,_) -> + let d' = if List.exists (F.eq_var x) d then d else (x::d) in + domain xs d' hs + + let reverse = List.map (fun (x,y) -> (y,x)) + + let freshen_sigma y = + List.map (fun u -> if F.eq_var (fst u) y then y,freshen y else u) + + let rec compute_bindings bindings sigmaR sigma = function + | [] -> bindings , sigma + | F.Fresh _ :: havocs -> compute_bindings bindings sigmaR sigma havocs + | F.Update(x,phi) :: havocs -> + let sigma' = freshen_sigma x sigma in + let x' = snd (List.find (fun (y,_) -> F.eq_var x y) sigma') in + let t' = apply sigmaR (phi sigma) in + compute_bindings ((x',t')::bindings) sigmaR sigma' havocs + + + let rec apply_bindings xts p = + match xts with + | [] -> p + | (x,t)::xts -> apply_bindings xts (subst x t p) + + let rec rename s p = + match s with + | [] -> p + | (x,x')::s -> subst x (F.var x') (rename s p) + + let rec fixpoint sf sn p = + match sf,sn with + | (_,x')::sf , (_,y)::sn -> + F.p_implies + (F.p_eq (F.var x') (F.var y)) + (fixpoint sf sn p) + | [] , [] -> p + | _ -> Wp_parameters.fatal "inconsistent domains in fixpoint substitutions" + + let havoc_inductive hs p = + let xs,d = domain [] [] hs in + let sigma_0 = List.map (fun x -> x,freshen x) d in + let sigma_F = List.map (fun x -> x,freshen x) d in + let bindings,sigma_N = compute_bindings [] sigma_F sigma_0 hs in + forall ( xs @ List.map snd sigma_F ) + (rename (reverse sigma_0) + (apply_bindings bindings + (fixpoint sigma_F sigma_N + (rename sigma_F p)))) + + let havoc_static hs p = + let xs,d = domain [] [] hs in + let sigma_0 = List.map (fun x -> x,freshen x) d in + let bindings,sigma_N = compute_bindings [] sigma_0 sigma_0 hs in + forall xs + (rename (reverse sigma_0) + (apply_bindings bindings + (rename sigma_N p))) + +end + +( -------------------------------------------------------------------------- ) +( --- Interpret C-runtime values --- ) +( -------------------------------------------------------------------------- ) + +module Cvalues(M : Mvalues.Model) = +struct + + module A = M.A + module R = M.R + module F = M.F + type loc = M.loc + type m_cell + type cell = F.abstract + + let loc_of_term = M.loc_of_term + let term_of_loc = M.term_of_loc + + let cast_int_to_loc = M.cast_int_to_loc + let cast_loc_to_int = M.cast_loc_to_int + + type value = + | V_int of Ctypes.c_int F.integer + | V_float of Ctypes.c_float * F.real + | V_pointer of Ctypes.c_object * M.loc + | V_record of compinfo * F.record + | V_union of compinfo * F.urecord + | V_array of arrayinfo * F.array + + let rec logic_of_value = function + | V_int(_,t) -> F.wrap t + | V_float(_,t) -> F.wrap t + | V_pointer(_,loc) -> F.wrap (M.term_of_loc loc) + | V_record(_,t) -> F.wrap t + | V_union(_,t) -> F.wrap t + | V_array(_,t) -> F.wrap t + + + let rec value_of_logic c_obj t = + match c_obj with + | C_int i -> V_int(i,F.unwrap t) + | C_float f -> V_float(f,F.unwrap t) + | C_pointer typ -> + V_pointer + (object_of typ, + M.loc_of_term (object_of typ) (F.unwrap t)) + | C_comp cinfo -> + if cinfo.cstruct + then V_record(cinfo,F.unwrap t) + else V_union(cinfo,F.unwrap t) + | C_array ainfo -> V_array(ainfo,F.unwrap t) + + let pp_loc = M.pp_loc + let pp_value fmt = function + | V_pointer(_,loc) -> M.pp_loc fmt loc + | v -> F.pp_term fmt (logic_of_value v) + + (* ------------------------------------------------------------------------ ) + ( --- Logic type of Values --- ) + ( ------------------------------------------------------------------------ ) + + let tau_of_loc = M.tau_of_loc + let tau_of_object = function + | C_int _ -> Integer + | C_float _ -> Real + | C_pointer _ -> Pointer tau_of_loc + | C_comp c -> Record c + | C_array a -> Array a + + let tau_of_object_array obj n = + let rec apply_dim t n = + ([LC] not perfect, but works ) + if n > 0 then ADT("farray",[apply_dim t (pred n)]) + else t + in apply_dim (tau_of_object obj) n + + let tau_of_ctype_logic t = tau_of_object (object_of t) + + let rec pp_tau fmt = function + | Formula.Integer -> pp_print_string fmt "int" + | Formula.Real -> pp_print_string fmt "real" + | Formula.Boolean -> pp_print_string fmt "bool" + | Formula.Pointer t -> Format.fprintf fmt "%a" pp_tau t + | Formula.Record c -> Format.fprintf fmt "%s" c.Cil_types.cname + | Formula.Array a -> + Format.fprintf fmt "%a farray" pp_tau + (tau_of_object (object_of a.arr_element)) + | Formula.Set te -> + if Wp_parameters.verbose_atleast 2 + then Format.fprintf fmt "%a set" pp_tau te + else pp_print_string fmt "set" + | Formula.ADT(s,[]) -> pp_print_string fmt s + | Formula.ADT(s,[t]) -> Format.fprintf fmt "%a %s" pp_tau t s + | Formula.ADT(s,t::ts) -> + Format.fprintf fmt "@[(%a" pp_tau t ; + List.iter (fun t -> Format.fprintf fmt ",@,%a" pp_tau t) ts ; + Format.fprintf fmt ") %s@]" s + + + let tau_of_ctype t = tau_of_object (Ctypes.object_of t) + + let rec tau_of_logic_type = function + | Ctype c -> tau_of_object (object_of c) + | Linteger -> Formula.Integer + | Lreal -> Formula.Real + | Ltype( d , [] ) when d.lt_name = Utf8_logic.boolean -> Formula.Boolean + | Ltype( {lt_name="set"} , [t] ) -> Formula.Set (tau_of_logic_type t) + | Ltype( lt , ts) -> + let d = F.adt_decl lt in + Formula.ADT (d,List.map tau_of_logic_type ts) + | Lvar _ -> Wp_parameters.not_yet_implemented "logic type variables" + | Larrow _ -> Wp_parameters.not_yet_implemented "type of logic function" + + + ( ------------------------------------------------------------------------ ) + ( --- Default Initialization of value --- ) + ( ------------------------------------------------------------------------ ) + + let init_value_term_rec = ref (fun _ _ _ -> assert false) + + module InitObj = F.DRegister + (struct + include F.Cobject + let declare obj _ = + Formula.Predicate [tau_of_object obj] + let prefix = "IsInit" + let section = S_Logic_Sig + let clear () = () + let pp_title fmt x = + Format.fprintf fmt + "Predicate is initial value of type %a" F.Cobject.pp_title x + end) + + + module InitObjRange = F.DRegister + (struct + include F.Cobject + let declare obj _ = + Formula.Predicate [tau_of_object_array obj 1;Integer;Integer] + let prefix = "IsInitRange" + let section = S_Logic_Sig + let clear () = () + let pp_title fmt x = + Format.fprintf fmt + "Initialisation of a range of type %a in a array" F.Cobject.pp_title x + end) + + module InitObjRangeDef = F.DRegister + (struct + include F.Cobject + let declare obj _ = + let pool = F.pool () in + let xt = F.p_fresh pool "t" + (Model (ADT("farray",[tau_of_object obj]))) + in + let t = F.var xt in + let xi = F.p_fresh pool "i" (Model Integer) in + let i = F.var xi in + let xlow = F.p_fresh pool "low" (Model Integer) in + let low = F.var xlow in + let xhigh = F.p_fresh pool "high" (Model Integer) in + let high = F.var xhigh in + let is_init = + F.p_app3 ((InitObjRange.get_definition obj).d_name) t low high + in + let i_low = F.p_icmp Cleq low i in + let i_high = F.p_icmp Clt i high in + let i_init = + !init_value_term_rec pool (F.acc_index (F.unwrap t) i) obj + in + let body = + F.p_forall [xi] + (F.p_implies i_low (F.p_implies i_high i_init)) + in + Formula.Axiom + (F.p_forall [xt;xlow;xhigh] (F.p_iff is_init body)) + + let prefix = "IsInitRangeDef" + let section = S_Logic_Prop + let clear () = () + let pp_title fmt x = + Format.fprintf fmt + "Initialisation of a range of type %a in a array" F.Cobject.pp_title x + end) + + let rec init_value_term pool x = function + | C_int _ -> F.p_eq x (F.wrap F.i_zero) + | C_float _ -> F.p_eq x (F.wrap F.r_zero) + | C_pointer te -> M.equal_loc (M.loc_of_term (object_of te) x) M.null + | C_array arr -> + let obj = object_of arr.arr_element in + begin + match arr.arr_flat with + | None -> F.p_true + | Some f -> + let bound = F.e_int64 f.arr_size in + InitObjRangeDef.define obj ; + F.p_app3 (InitObjRange.get_definition obj).d_name x + F.i_zero bound + end + + | C_comp cp -> + begin + let get_f f = F.acc_field (F.unwrap x) f in + let field_init f = + init_value_term pool (get_f f) (object_of f.ftype) + in + List.fold_left (fun p f -> F.p_and p (field_init f)) + F.p_true cp.cfields + end + + module InitObjDef = F.DRegister + (struct + include F.Cobject + let declare obj _ = + let p_is_init = (InitObj.get_definition obj).d_name in + let pool = F.pool () in + let vx = F.p_fresh pool "x" (Model (tau_of_object obj)) in + let x = F.var vx in + let is_init_x = F.p_app1 p_is_init x in + let body = init_value_term pool x obj in + Formula.Axiom (F.p_forall [vx ] (F.p_iff is_init_x body)) + + let prefix = "IsInitDef" + let section = S_Logic_Prop + let clear () = () + let pp_title fmt x = + Format.fprintf fmt + "Axiomatic definition of the predicate of is initial value of type %a" F.Cobject.pp_title x + let prefix = "IsInitRangeDef" + let clear () = () + let pp_title fmt x = + Format.fprintf fmt + "Initialisation of a range of type %a in a array" F.Cobject.pp_title x + end) + + let rec init_value_term pool x = function + | C_int _ -> F.p_eq x (F.wrap F.i_zero) + | C_float _ -> F.p_eq x (F.wrap F.r_zero) + | C_pointer te -> M.equal_loc (M.loc_of_term (object_of te) x) M.null + | C_array arr -> + let obj = object_of arr.arr_element in + begin + match arr.arr_flat with + | None -> F.p_true + | Some f -> + let bound = F.e_int64 f.arr_size in + InitObjRangeDef.define obj ; + F.p_app3 (InitObjRange.get_definition obj).d_name x + F.i_zero bound + end + + | C_comp cp -> + begin + let get_f f = F.acc_field (F.unwrap x) f in + let field_init f = + init_value_term pool (get_f f) (object_of f.ftype) + in + List.fold_left (fun p f -> F.p_and p (field_init f)) + F.p_true cp.cfields + end + + + let () = init_value_term_rec := init_value_term + + let symb_is_init obj = + if Ctypes.no_infinite_array obj then + (InitObjDef.define obj ; + Some (InitObj.get_definition obj).d_name) + else None + + let symb_is_init_range obj = + if Ctypes.no_infinite_array obj then + (InitObjRangeDef.define obj; + Some (InitObjRange.get_definition obj).d_name) + else None + + ( ------------------------------------------------------------------------ ) + ( --- Pointer Arithmetics --- ) + ( ------------------------------------------------------------------------ ) + + let lt_loc = M.lt_loc + let le_loc = M.le_loc + + let minus_loc = M.minus_loc + + let equal_loc_bool = M.equal_loc_bool + let lt_loc_bool = M.lt_loc_bool + let le_loc_bool = M.le_loc_bool + let equal_loc = M.equal_loc + let le_loc = M.le_loc + let lt_loc = M.lt_loc + + let null = M.null + let is_null = M.is_null + + ( ------------------------------------------------------------------------ ) + ( --- Comparison of Record and Arrays --- ) + ( ------------------------------------------------------------------------ *) + + module RecEqName = F.DRegister + (struct + include F.Compinfo + let declare tcomp _eqname = + Formula.Predicate[Record tcomp;Record tcomp] + let prefix = "Eqrec" + let section = S_Logic_Sig + let clear () = () + let pp_title fmt x = + Format.fprintf fmt "Equality for %a" + F.Compinfo.pp_title x + end) + + + let equal_rec = ref (fun _ _ _ -> assert false) + + (** 2 struct or union objects are equal when all the fields are equal. ) + let eq_record_definition tcomp eq_name = + let pool = F.pool() in + let xa = F.p_fresh pool "a" (Model (Record tcomp)) in + let xb = F.p_fresh pool "b" (Model (Record tcomp)) in + let ra = F.var xa in + let rb = F.var xb in + let p_comp = + List.fold_left + (fun p field -> + let tf = Ctypes.object_of field.ftype in + let va = F.acc_field ra field in + let vb = F.acc_field rb field in + let ef = !equal_rec tf va vb in + F.p_and p ef + ) F.p_true tcomp.cfields + in + F.p_forall [xa;xb] + (F.p_iff (F.p_app2 eq_name ra rb) p_comp) + + let eq_array_definition ta eq_name = + let pool = F.pool() in + let te = Ctypes.object_of ta.arr_element in + let vmodel = Model(Array ta) in + let xa = F.p_fresh pool "a" vmodel in + let xb = F.p_fresh pool "b" vmodel in + let ra = F.var xa in + let rb = F.var xb in + let xi = F.p_fresh pool "i" (Model Integer) in + let vi = F.var xi in + let i_pos = F.p_icmp Cleq (F.i_zero) vi in + let i_max = + match ta.arr_flat with + | None -> F.p_true + | Some f -> F.p_icmp Clt vi (F.e_icst (Int64.to_string f.arr_size)) + in + let i_range = F.p_and i_pos i_max in + let a_comp = + F.p_forall [xi] + (F.p_implies + i_range + (!equal_rec te (F.acc_index ra vi) (F.acc_index rb vi))) in + F.p_forall [xa;xb] + (F.p_iff (F.p_app2 eq_name ra rb) a_comp) + + + module RecEqSym = F.DRegister + (struct + include F.Compinfo + let declare tcomp _eqname = + let eq_name = F.p_app2 (RecEqName.get_definition tcomp).d_name in + let pool = F.pool() in + let xa = F.p_fresh pool "a" (Model (Record tcomp)) in + let ra = F.var xa in + let p = F.p_forall [xa] (eq_name ra ra) in + Formula.Axiom p + let prefix = "EqrecSym" + let section = S_Logic_Prop + let clear () = () + let pp_title fmt x = + Format.fprintf fmt "Symmetry of Equality for %a" + F.Compinfo.pp_title x + let pp_descr fmt _ = + Format.pp_print_string fmt "Axiomatic Definition" + end) + + + module RecEqTrans = F.DRegister + (struct + include F.Compinfo + let declare tcomp _eqname = + let eq_name = F.p_app2 (RecEqName.get_definition tcomp).d_name in + let pool = F.pool() in + let xa = F.p_fresh pool "a" (Model (Record tcomp)) in + let ra = F.var xa in + let xb = F.p_fresh pool "b" (Model (Record tcomp)) in + let rb = F.var xb in + let xc = F.p_fresh pool "c" (Model (Record tcomp)) in + let rc = F.var xc in + Formula.Axiom + (F.p_forall [xa;xb;xc] + (F.p_implies (eq_name ra rb) + (F.p_implies (eq_name rb rc) (eq_name ra rc)))) + let prefix = "EqrecTrans" + let section = S_Logic_Prop + let clear () = () + let pp_title fmt x = + Format.fprintf fmt "Symmetry of Equality for %a" + F.Compinfo.pp_title x + let pp_descr fmt _ = + Format.pp_print_string fmt "Axiomatic Definition" + end) + + module RecEqDef = F.DRegister + (struct + include F.Compinfo + let declare tcomp _axname = + let eq_name = RecEqName.get_definition tcomp in + RecEqSym.define tcomp ; + RecEqTrans.define tcomp ; + Formula.Axiom(eq_record_definition tcomp eq_name.d_name) + let prefix = "EqrecDef" + let section = S_Logic_Prop + let clear () = () + let pp_title fmt x = + Format.fprintf fmt "Equality for %a" + F.Compinfo.pp_title x + let pp_descr fmt _ = + Format.pp_print_string fmt "Axiomatic Definition" + end) + + module ArrEqName = F.DRegister + (struct + include F.Arrayinfo + let declare arr _eqname = + Formula.Predicate[Array arr;Array arr] + let prefix = "Eqarr" + let section = S_Logic_Sig + let clear () = () + let pp_title fmt x = + Format.fprintf fmt "Equality for %a" F.Arrayinfo.pp_title x + end) + + module ArrEqDef = F.DRegister + (struct + include F.Arrayinfo + let declare arr _axname = + let eq_name = ArrEqName.get_definition arr in + Formula.Axiom(eq_array_definition arr eq_name.d_name) + let prefix = "EqarrDef" + let section = S_Logic_Prop + let clear () = () + let pp_title fmt x = + Format.fprintf fmt "Equality for %a" + F.Arrayinfo.pp_title x + let pp_descr fmt _ = + Format.pp_print_string fmt "Axiomatic Definition" + end) + + let eq_record comp (ta:F.record) (tb:F.record) = + if comp.cfields <>[] then RecEqDef.define comp ; + let eq = RecEqName.get_definition comp in + F.p_app2 eq.d_name ta tb + + let eq_array arr (ta:F.array) (tb:F.array) = + ArrEqDef.define arr ; + let eq = ArrEqName.get_definition arr in + F.p_app2 eq.d_name ta tb + + let equal te a b = + match te with + | C_int _ | C_float _ -> F.p_eq a b + | C_pointer t -> + let obj = object_of t in + M.equal_loc (M.loc_of_term obj a) (M.loc_of_term obj b) + | C_comp comp -> eq_record comp (F.unwrap a) (F.unwrap b) + | C_array arr -> eq_array arr (F.unwrap a) (F.unwrap b) + + let () = equal_rec := equal + +end + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/datalib.mli frama-c-20111001+nitrogen+dfsg/src/wp/datalib.mli --- frama-c-20110201+carbon+dfsg/src/wp/datalib.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/datalib.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,66 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types +open Ctypes +open Formula + + +module Cvalues(M : Mvalues.Model) : Mvalues.Values + with type loc = M.loc + and module F = M.F + and module A = M.A + and module R = M.R + + +module Collector : sig + type t + + val push : unit -> t + val pop : t -> Wpo.warning list * Property.t list + + (** + * When adding a warning, one has to provide : + * - the source of the warning (for instance "model M"), + * - the effect of the warning (for instance "stop computation") + * - and a formated message about why this warning is emited. + ) + val add_warning : ?severe:bool -> ?source:string -> reason:string -> + ('a, Format.formatter, unit) format -> 'a + + val add_depend : Property.t -> unit + +end + + + + + +module Create (V:Mvalues.Values) : Formula.Logic with module F = V.F + + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/data_mem.ml frama-c-20111001+nitrogen+dfsg/src/wp/data_mem.ml --- frama-c-20110201+carbon+dfsg/src/wp/data_mem.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/data_mem.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,335 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Proof Environment to deal with Arrays and Record in Memory Models --- ) +( -------------------------------------------------------------------------- ) + +open Formula +open Cil_types +open Ctypes + +module Create(M : Mvalues.Data) = +struct + module F = M.F + + ( Declaration of record format ) + + module Cformat = F.DRegister + (struct + include F.Compinfo + let prefix = "Cfmt" + let section = S_Cons + let clear () = () + let pp_title fmt c = + Format.fprintf fmt "Format for %s '%s'" + (if c.cstruct then "struct" else "union") c.cname + let declare comp _ = + Function ([],Formula.ADT("format",[Record comp])) + end) + + ( Declaration of array format ) + + module Aformat = F.DRegister + (struct + include F.Arrayinfo + let prefix = "Afmt" + let section = S_Cons + let clear () = () + let pp_title fmt arr = + Format.fprintf fmt "Format for array %a" + Ctypes.pretty (C_array arr) + let pp_descr fmt _ = + Format.fprintf fmt "Decode array from memory" + let declare arr _ = + Function ([],Formula.ADT("format",[Array arr])) + end) + + ( ------------------------------------------------------------------------ ) + ( --- Utilities --- ) + ( ------------------------------------------------------------------------ ) + + let in_range arr xi = + let i_pos = F.p_icmp Cleq F.i_zero xi in + let i_max = match arr.arr_flat with + | None -> F.p_true + | Some a -> F.p_icmp Clt xi (F.e_icst (Int64.to_string a.arr_size)) + in F.p_and i_pos i_max + + module Compound(R : sig val prefix : string end) : + sig + val add_axiom : string -> Lexing.position option + -> string -> string -> F.pred -> unit + val on_array : (arrayinfo -> unit) -> unit + val on_record : (compinfo -> unit) -> unit + val define : c_object -> unit + end + = + struct + + module Hcomp = F.Compinfo.H + module Harray = F.Arrayinfo.H + + let cindex = Hcomp.create 131 + let aindex = Harray.create 131 + let clear () = Hcomp.clear cindex ; Harray.clear aindex + let () = Fol_decl.register_prefix R.prefix + let () = F.on_clear clear + + let add_axiom obj src name path prop = + let dname = F.fresh_name R.prefix name in + F.add_declaration { + d_name = dname ; + d_section = S_Model_Prop ; + d_source = src ; + d_item = Formula.Axiom prop ; + d_title = (fun fmt -> Format.fprintf fmt "%s in loaded object %s" R.prefix obj) ; + d_descr = (fun fmt -> Format.fprintf fmt "Path %s" path) ; + } + + let define_array = ref (fun _ -> assert false) + let define_comp = ref (fun _ -> assert false) + + let on_array f = define_array := f + let on_record f = define_comp := f + + let define = function + | C_array arr -> + let key = F.Arrayinfo.index arr in + if not (Harray.mem aindex key) then + ( Harray.add aindex key () ; !define_array arr ) + + | C_comp comp -> + let key = F.Compinfo.index comp in + if not (Hcomp.mem cindex key) then + ( Hcomp.add cindex key () ; !define_comp comp ) + | _ -> () + + end + + ( ------------------------------------------------------------------------ ) + ( --- Axioms for accessing sub-terms in loaded compounds --- ) + ( ------------------------------------------------------------------------ ) + + module LoadedCompound = + struct + + include Compound(struct let prefix = "Loaded" end) + + let rec define_access obj pool name path xs mem loc tr = + match tr with + + | C_array arr -> + let te = Ctypes.object_of arr.arr_element in + let xi = F.p_fresh pool "i" (Model Formula.Integer) in + let loc' = M.index loc te (F.var xi) in + let r = M.logic_of_value (M.load_mem mem tr loc) in + let v = F.acc_index (F.unwrap r) (F.var xi) in + let v' = M.logic_of_value (M.load_mem mem te loc') in + let xs' = xs @ [xi] in + let prop = + F.p_forall xs' + (F.p_implies (in_range arr (F.var xi)) (M.equal te v v')) + in + let name' = Pretty_utils.sfprintf "%s_idx" name in + let path' = Pretty_utils.sfprintf "%s[%a]" path F.pp_term (F.var xi) in + add_axiom obj (F.Arrayinfo.location arr) name' path' prop ; + define_access obj pool name' path' xs' mem loc' te + + | C_comp comp -> + List.iter + (fun f -> + let te = Ctypes.object_of f.ftype in + let loc' = M.field loc f in + let r = M.logic_of_value (M.load_mem mem tr loc) in + let v = F.acc_field (F.unwrap r) f in + let v' = M.logic_of_value (M.load_mem mem te loc') in + let prop = F.p_forall xs (M.equal te v v') in + let name' = Format.sprintf "%s_%s" name f.fname in + let path' = Format.sprintf "%s.%s" name f.fname in + add_axiom obj (F.Compinfo.location comp) name' path' prop ; + define_access obj pool name' path' xs mem loc' te + ) comp.cfields + + | _ -> () + + let define_array arr = + let pool = F.pool () in + let name = F.Arrayinfo.basename arr in + let path = "array" in + let xm = F.p_fresh pool "m" (Model M.tau_of_mem) in + let xa,a = M.forall_loc pool in + define_access name pool name path (xm::xa) (F.var xm) a (C_array arr) + + let define_comp comp = + let pool = F.pool () in + let name = F.Compinfo.basename comp in + let path = comp.cname in + let xm = F.p_fresh pool "m" (Model M.tau_of_mem) in + let xa,a = M.forall_loc pool in + define_access name pool name path (xm::xa) (F.var xm) a (C_comp comp) + + let () = on_array define_array + let () = on_record define_comp + + end + + ( -------------------------------------------------------------------------- ) + ( --- Axioms for accessing sub-terms in stored compounds --- ) + ( -------------------------------------------------------------------------- ) + + module StoredCompound = + struct + + include Compound(struct let prefix = "Stored" end) + + let rec define_update obj pool name path xs mem loc tr r = + match tr with + + | C_array arr -> + let xi = F.p_fresh pool "i" (Model Formula.Integer) in + let te = Ctypes.object_of arr.arr_element in + let mem' = M.store_mem mem tr loc (M.value_of_logic tr r) in + let loc' = M.index loc te (F.var xi) in + let ve = F.acc_index (F.unwrap r) (F.var xi) in + let v' = M.logic_of_value (M.load_mem mem' te loc') in + let xs' = xs @ [xi] in + let prop = F.p_forall xs' + (F.p_implies (in_range arr (F.var xi)) (M.equal te ve v')) in + let name' = Pretty_utils.sfprintf "%s_idx" name in + let path' = Pretty_utils.sfprintf "%s[%a]" path F.pp_var xi in + add_axiom obj (F.Arrayinfo.location arr) name' path' prop ; + define_update obj pool name' path' xs' mem' loc' te ve + + | C_comp comp -> + List.iter + (fun f -> + let te = Ctypes.object_of f.ftype in + let mem' = M.store_mem mem tr loc (M.value_of_logic tr r) in + let loc' = M.field loc f in + let ve = F.acc_field (F.unwrap r) f in + let v' = M.logic_of_value (M.load_mem mem' te loc') in + let prop = F.p_forall xs (M.equal te ve v') in + let name' = Format.sprintf "%s_%s" name f.fname in + let path' = Format.sprintf "%s.%s" name f.fname in + add_axiom obj (F.Compinfo.location comp) name' path' prop ; + define_update obj pool name' path' xs mem loc' te ve + ) comp.cfields + + | _ -> () + + + let define_array arr = + let pool = F.pool () in + let name = F.Arrayinfo.basename arr in + let path = "array" in + let xm = F.p_fresh pool "m" (Model M.tau_of_mem) in + let xr = F.p_fresh pool "r" (Model (Array arr)) in + let xa,a = M.forall_loc pool in + define_update name pool name path + (xm::xr::xa) (F.var xm) a (C_array arr) (F.var xr) + + let define_comp comp = + let pool = F.pool () in + let name = F.Compinfo.basename comp in + let path = comp.cname in + let xm = F.p_fresh pool "m" (Model M.tau_of_mem) in + let xr = F.p_fresh pool "r" (Model (Record comp)) in + let xa,a = M.forall_loc pool in + define_update name pool name path + (xm::xr::xa) (F.var xm) a (C_comp comp) (F.var xr) + + let () = on_array define_array + let () = on_record define_comp + + end + + ( -------------------------------------------------------------------------- ) + ( --- Axioms for loading an object after a store inside --- ) + ( -------------------------------------------------------------------------- ) + + module UpdatedCompound = + struct + + include Compound(struct let prefix = "Updated" end) + + let define_array arr = + let tr = C_array arr in + let te = Ctypes.object_of arr.arr_element in + let pool = F.pool () in + let xm = F.p_fresh pool "m" (Model M.tau_of_mem) in + let xa,loc = M.forall_loc pool in + let xi = F.p_fresh pool "i" (Model Integer) in + let xv = F.p_fresh pool "e" (Model (M.tau_of_object te)) in + let mem = F.var xm in + let loc' = M.index loc te (F.var xi) in + let mem' = M.store_mem mem te loc' (M.value_of_logic te (F.var xv)) in + let r0 = M.logic_of_value (M.load_mem mem tr loc) in + let r1 = M.logic_of_value (M.load_mem mem' tr loc) in + let r2 = F.wrap (F.upd_index (F.unwrap r0) (F.var xi) (F.var xv)) in + let prop = F.p_forall (xm::xi::xv::xa) + (F.p_implies (in_range arr (F.var xi)) (M.equal tr r1 r2)) in + let name = F.Arrayinfo.basename arr in + let path = Pretty_utils.sfprintf "%s.[%a]" name F.pp_var xi in + add_axiom name (F.Arrayinfo.location arr) name path prop + + let define_comp comp = + List.iter + (fun f -> + let tr = C_comp comp in + let te = Ctypes.object_of f.ftype in + let pool = F.pool () in + let xm = F.p_fresh pool "m" (Model M.tau_of_mem) in + let xa,loc = M.forall_loc pool in + let xv = F.p_fresh pool "e" (Model (M.tau_of_object te)) in + let mem = F.var xm in + let loc' = M.field loc f in + let mem' = M.store_mem mem te loc' (M.value_of_logic te (F.var xv)) in + let r0 = M.logic_of_value (M.load_mem mem tr loc) in + let r1 = M.logic_of_value (M.load_mem mem' tr loc) in + let r2 = F.wrap (F.upd_field (F.unwrap r0) f (F.var xv)) in + let prop = F.p_forall (xm::xv::xa) (M.equal tr r1 r2) in + let name = F.Compinfo.basename comp in + let path = Pretty_utils.sfprintf "%s.%s" name f.fname in + add_axiom name (F.Compinfo.location comp) name path prop + ) comp.cfields + + let () = on_array define_array + let () = on_record define_comp + + end + + ( -------------------------------------------------------------------------- ) + ( --- API --- ) + ( -------------------------------------------------------------------------- ) + + let record_format comp = F.e_app0 (Cformat.get_definition comp).d_name + let array_format arr = F.e_app0 (Aformat.get_definition arr).d_name + + ( -------------------------------------------------------------------------- ) + ( --- Registration --- ) + ( -------------------------------------------------------------------------- *) + + let loaded te = LoadedCompound.define te ; UpdatedCompound.define te + let stored te = StoredCompound.define te + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/data_mem.mli frama-c-20111001+nitrogen+dfsg/src/wp/data_mem.mli --- frama-c-20110201+carbon+dfsg/src/wp/data_mem.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/data_mem.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,39 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Proof Environment to deal with Arrays and Record in Memory Models --- ) +( -------------------------------------------------------------------------- *) + +open Cil_types +open Ctypes + +module Create(M : Mvalues.Data) : +sig + + val record_format : compinfo -> 'a M.F.term + val array_format : arrayinfo -> 'a M.F.term + + val loaded : c_object -> unit + val stored : c_object -> unit + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_cc.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_cc.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_cc.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_cc.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,130 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ ) +( --- Remove let with Closure Conversion ) +( ------------------------------------------------------------------------ ) + +open Fol + +( I. such as closure conversion : + This section is for generated terms and predicate + for ergo and for coq output. + Tlet (x,t1,t2) becomes Tapp(f,t1::free_vars t2) + when f is a function such that : + {name = f; param =x::free_vars t2 ; body = t2} + Plet (x,t,p) becomes Pforall(nx,Pimplies(Papp("eq",[Tvar nx;t]),p) + +) + +( [free_vars bvars fvars t] computes the free variables of [t] without + repetition, accroding to the already bound variables [bvars] and + the already found free variables [fvars] *) +let rec free_vars bvars fvars = function + | Tlet(x,t1,t2) -> + let f1 = free_vars bvars fvars t1 in + free_vars (Vset.add x bvars) f1 t2 + | Tapp(_f,tl) -> + (List.fold_left (fun f t -> free_vars bvars f t) fvars tl) + | Tif (c,tt,tf) -> + let fc = free_vars bvars fvars c in + let ftt = free_vars bvars fc tt in + free_vars bvars ftt tf + | Tvar x -> + if Vset.mem x bvars then fvars else (Vset.add x fvars) + | _ -> fvars + + +type f_let = + { name : string ; + param : Var.t list ; + body : term;} + +let mk_def xl t defs = + let f = "_let_"^(string_of_int (snd !defs) ) in + defs := + ({name = f ; param = xl; body = t}::(fst !defs)), + 1+(snd !defs);f + +let new_name x sigma cpt = + incr cpt; + let sx = Var.basename x^(string_of_int !cpt) in + let nx = Var.fresh_named_var sx (Var.var_type x) in + nx,(Vmap.add x nx sigma) + +let rec unlet_term sigma bvars defs = function + | Tlet(x,t1,t2) -> + let fvars = free_vars (Vset.add x bvars) Vset.empty t2 in + let args = x::(Vset.elements fvars) in + let t2' = unlet_term sigma (Vset.add x bvars) defs t2 in + let f = mk_def args t2' defs in + e_app f + ((unlet_term sigma bvars defs t1):: + (List.map (fun x -> e_var x) args)) + | Tapp(f,tl) -> + e_app f (List.map (fun t -> unlet_term sigma bvars defs t) tl) + | Tif (c,tt,tf) -> + e_if (unlet_term sigma bvars defs c) + (unlet_term sigma bvars defs tt) + (unlet_term sigma bvars defs tf) + | Tvar x -> e_var (try Vmap.find x sigma with Not_found -> x) + | t -> t + +let rec unlet_pred sigma bvars defs cpt = function + | Papp (f, tl) -> + p_app f (List.map (fun t -> unlet_term sigma bvars defs t) tl) + | Pimplies (p1,p2) -> + Pimplies(unlet_pred sigma bvars defs cpt p1, + unlet_pred sigma bvars defs cpt p2) + | Pif (t,p1,p2) -> + Pif(unlet_term sigma bvars defs t, + unlet_pred sigma bvars defs cpt p1, + unlet_pred sigma bvars defs cpt p2) + | Pand (p1,p2) -> + Pand(unlet_pred sigma bvars defs cpt p1, unlet_pred sigma bvars defs cpt p2) + | Por (p1,p2) -> + Por(unlet_pred sigma bvars defs cpt p1, unlet_pred sigma bvars defs cpt p2) + | Piff (p1,p2) -> + Piff(unlet_pred sigma bvars defs cpt p1, unlet_pred sigma bvars defs cpt p2) + | Pnot p -> Pnot (unlet_pred sigma bvars defs cpt p) + | Pforall (x,p) -> + let nx,nsigma = new_name x sigma cpt in + Pforall(nx,unlet_pred nsigma (Vset.add x bvars) defs cpt p) + | Pexists(x,p) -> + let nx,nsigma = new_name x sigma cpt in + Pexists(nx,unlet_pred nsigma (Vset.add x bvars) defs cpt p) + | Plet (x,t,p) -> + let nx,nsigma = new_name x sigma cpt in + let b = Vset.add x bvars in + p_forall nx + (p_implies + (p_app "eq" [e_var nx;unlet_term sigma b defs t]) + (unlet_pred nsigma b defs cpt p)) + | Pnamed(s,p) -> Pnamed(s,unlet_pred sigma bvars defs cpt p) + | p -> p + + +let unlet p = + let cpt = ref 0 in + let defs= ref ([] , 0) in + let p' = unlet_pred Vmap.empty Vset.empty defs cpt p in + (fst !defs),p' diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_coq.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_coq.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_coq.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_coq.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,422 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Fol +open Fol_norm +open Formula +open Format + +(* -------------------------------------------------------------------------- ) +( --- Coq Export --- ) +( -------------------------------------------------------------------------- ) + +let get_ufield f = "get_"^(f.Cil_types.fname)^"_"^(f.Cil_types.fcomp.Cil_types.cname) +let set_ufield f = "set_"^(f.Cil_types.fname)^"_"^(f.Cil_types.fcomp.Cil_types.cname) + +let constant fmt = function + | ConstInt n -> + let k = Big_int.big_int_of_string n in + if Big_int.lt_big_int k Big_int.zero_big_int then + pp_print_string fmt ("( "^n^" )") + else pp_print_string fmt n + | ConstBool b -> pp_print_string fmt (if b then "true" else "false") + | ConstUnit -> pp_print_string fmt "void" + | ConstFloat f -> fprintf fmt "%s%%R" (Kreal.convert f) + +let pp_list pp fmt = function + | [] -> () + | x::xs -> + pp fmt x ; + List.iter (fun x -> fprintf fmt " @,%a" pp x) xs + +let pp_typelist pp fmt = function + | [] -> () + | x::xs -> + pp fmt x ; + List.iter (fun x -> fprintf fmt " @,->%a" pp x) xs + +let pp_flow fmt nil op pp = function + | [] -> + pp_print_string fmt nil + | x::xs -> + fprintf fmt "@[<hov 1>(%a" pp x ; + List.iter (fun x -> fprintf fmt "@, %s%a" op pp x) xs ; + fprintf fmt ")@]" + +let pp_block fmt tab op pp ps = + match ps with + | [] -> () + | p::ps -> + fprintf fmt "%s %a" tab pp p ; + List.iter (fun p -> fprintf fmt "@\n%s %a" op pp p) ps + +let pp_var fmt v = + let name = Fol_decl.identifier (Var.var_name v) in + fprintf fmt "%s" name + +let rec collect_assoc op xs = function + | [] -> List.rev xs + | Tapp(id,ts) :: others when id = op -> + collect_assoc op (collect_assoc op xs ts) others + | t::others -> + collect_assoc op (t::xs) others + +let field f = "field_"^f.Cil_types.fname^"_"^f.Cil_types.fcomp.Cil_types.cname +let ufield f = "field_"^f.Cil_types.fname^"_"^f.Cil_types.fcomp.Cil_types.cname + +let fpp_term term fmt t = + match t with + | Tconst c -> constant fmt c + | Tvar v -> pp_var fmt v + | Tapp (id, []) -> pp_print_string fmt id + | Tapp ("ite",[c;a;b]) | Tif (c,a,b) -> + fprintf fmt "(@[<v 0>if %a@ then %a@ else %a@])" + term c term a term b + | Tapp ("neg_int",[a]) -> + fprintf fmt "@[<hov 1> (-%a)@]" term a + | Tapp ("add_int", ts) -> + let xs = collect_assoc "add_int" [] ts in + pp_flow fmt "0" "+" term xs + | Tapp ("sub_int", [a;b]) -> + fprintf fmt "@[<hov 1>(%a@ -%a)@]" term a term b + | Tapp ("mul_int", ts) -> + let xs = collect_assoc "mul_int" [] ts in + pp_flow fmt "1" "" term xs + | Tapp (id, t::ts) -> + fprintf fmt "@[<hov 2>(%s@, %a" id term t ; + List.iter (fun t -> fprintf fmt " @, %a" term t) ts ; + fprintf fmt ")@]" + | Tlet (x,v,t) -> + fprintf fmt "(@[<v 0>let %a@ := %a@ in %a@])" + pp_var x term v term t + | Taccess(t,i) -> + fprintf fmt "@[<hov 2>(access@, %a@, %a)@]" term t term i + | Tupdate(t,i,v) -> + fprintf fmt "@[<hov 2>(update@, %a@, %a@, %a)@]" term t term i term v + | Tgetfield(f,r) -> + if f.Cil_types.fcomp.Cil_types.cstruct then + fprintf fmt "@[<hov 2>(%a.(%s))@]" term r (field f) + else (fprintf fmt "@[<hov 2>(%s @, %a)@]"(get_ufield f) term r) + | Tsetfield(f,r,v) -> + let cp = f.Cil_types.fcomp in + if cp.Cil_types.cstruct then + begin + let built_rec = "mk"^(String.capitalize cp.Cil_types.cname) in + fprintf fmt "@[<hov 2> ( %s " built_rec; + List.iter (fun g -> + (if Cil_datatype.Fieldinfo.equal g f then + Format.fprintf fmt"(%a)@]" term v + else + Format.fprintf fmt "%a.(%s)" term r (field g)) + ) cp.Cil_types.cfields ; + fprintf fmt ")@]" + end + else fprintf fmt "@[<hov 2>(%s @, %a @, %a)@]"(set_ufield f) term r term v + +let rec collect_or ps = function + | Por(a,b) -> collect_or (collect_or ps b) a + | p -> p :: ps + +let rec collect_and ps = function + | Pand(a,b) -> collect_and (collect_and ps b) a + | p -> p :: ps + +let rec collect_imply ps = function + | Pimplies(a,b) -> collect_and (collect_imply ps b) a + | p -> p :: ps + +let rec collect_iff ps = function + | Piff(a,b) -> collect_iff (collect_iff ps b) a + | p -> p :: ps + +type 'a pp = Format.formatter -> 'a -> unit +type pp_env = { + pp_type : Formula.tau pp ; + pp_term : term pp ; + pp_pred : pred pp ; +} + +let pp_args pp_tau fmt = function + | [] -> () + | [x] -> Format.fprintf fmt "(%a@,:@,%a)@,:%a@,=@," + pp_var x pp_tau (Var.var_type x) pp_tau (Var.var_type x) + | x::m -> + Format.fprintf fmt "(%a@,:@,%a)@," + pp_var x pp_tau (Var.var_type x); + List.iter (fun x -> Format.fprintf fmt "@,(%a@,:@,%a)@," + pp_var x pp_tau (Var.var_type x) ) m; + Format.fprintf fmt "@,:%a@,=@\n" pp_tau (Var.var_type x) + +open Fol_cc + +let fpp_f_let pp_tau pp_term fmt fl = + Format.fprintf fmt "@[<hov 2>Definition %s@,%a%a@]" + fl.name (pp_args pp_tau) fl.param + pp_term fl.body + +let fpp_lf_let pp_tau pp_term fmt = function + | [] -> () + | x::xs -> + let pp = fpp_f_let pp_tau pp_term in + pp fmt x ; + List.iter (fun x -> fprintf fmt "%a@\n" pp x ) xs + +let rec epp_pred_vbox env fmt p = + match p with + | Pand _ -> pp_block fmt " " " /\\ " env.pp_pred (collect_and [] p) + | Por _ -> pp_block fmt " " " \\/ " env.pp_pred (collect_or [] p) + | Pimplies _ -> pp_block fmt " " "->" env.pp_pred (collect_imply [] p) + | Piff _ -> pp_block fmt " " "<->" env.pp_pred (collect_iff [] p) + | Pforall(x,p) -> + fprintf fmt "forall (%a:%a),@\n" pp_var x env.pp_type (Var.var_type x) ; + epp_pred_vbox env fmt p + | Pexists(x,p) -> + fprintf fmt "exists %a:%a,@\n" pp_var x env.pp_type (Var.var_type x) ; + epp_pred_vbox env fmt p + | Plet(x,t,p) -> + fprintf fmt "@[<hov 2>let %a:=@ %a@ in @]@\n" pp_var x env.pp_term t ; + epp_pred_vbox env fmt p + | Pif(t,p,q) -> + fprintf fmt "@[<hov 0>if @[<hov 2>%a@]@ then@]@\n %a@\nelse@\n %a" + env.pp_term t env.pp_pred p env.pp_pred q + | (Ptrue | Pfalse | Papp _ | Pnot _ | Pnamed _) -> + env.pp_pred fmt p + +let rec epp_pred_atom env fmt p = + match p with + | Pand _ | Por _ | Pimplies _ | Piff _ | Pif _ + | Pforall _ | Pexists _ | Plet _ -> + fprintf fmt "@[<v 1>(%a)@]" (epp_pred_vbox env) p + | Pnot p -> + fprintf fmt "@[<hov 2>(~@ %a)@]" (epp_pred_atom env) p + | Pnamed(tag,p) -> + fprintf fmt "@[<hov 0>(%s:)@,%a@]" tag (epp_pred_atom env) p + | Ptrue -> pp_print_string fmt "True" + | Pfalse -> pp_print_string fmt "False" + | Papp(id,[]) -> pp_print_string fmt id + | Papp (("eq" | "eq_int" | "eq_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ =@ %a)@]" env.pp_term t1 env.pp_term t2 + | Papp (("neq" | "neq_int" | "neq_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ <>@ %a)@]" env.pp_term t1 env.pp_term t2 + | Papp (("lt_int"| "lt_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ <@ %a)@]" env.pp_term t1 env.pp_term t2 + | Papp (("le_int"| "le_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ <=@ %a)@]" env.pp_term t1 env.pp_term t2 + | Papp(id,t::ts) -> + fprintf fmt "@[<hov 2>(%s @,%a" id env.pp_term t ; + List.iter (fun t -> fprintf fmt "@ %a" env.pp_term t) ts ; + fprintf fmt ")@]" + +let fpp_pred predicate pp_term pp_type fmt p = + match p with + | Ptrue -> fprintf fmt "True" + | Pfalse -> fprintf fmt "False" + | Papp (id, [])-> fprintf fmt "%s" id + | Papp ("eq", [t1; t2]) -> fprintf fmt "(%a =@ %a)" pp_term t1 pp_term t2 + | Papp ("neq", [t1; t2]) -> fprintf fmt "(%a <>@ %a)" pp_term t1 pp_term t2 + | Papp (id, l) -> fprintf fmt "@[(%s @, %a)@]" id (pp_list pp_term) l + | Pimplies (a, b) -> fprintf fmt "(@[%a ->@ %a@])" predicate a predicate b + | Piff (a, b) -> fprintf fmt "(@[%a <->@ %a@])" predicate a predicate b + | Pand (a, b) -> fprintf fmt "(@[%a /\\ @ %a@])" predicate a predicate b + | Por (a, b) -> fprintf fmt "(@[%a \\/ @ %a@])" predicate a predicate b + | Pnot a -> fprintf fmt "(~ %a)" predicate a + | Pif (a, b, c) -> + fprintf fmt "(@[if %a then@ %a else@ %a@])" + pp_term a predicate b predicate c + | Pforall (v,p) -> + fprintf fmt "@[<hov 0>(forall (%a:%a),@ %a@])" + pp_var v pp_type (Var.var_type v) predicate p + | Pexists (v,p) -> + fprintf fmt "@[<hov 0>(exists %a:%a,@ %a@])" + pp_var v pp_type (Var.var_type v) predicate p + | Plet (x,v,p) -> + fprintf fmt "@[<hov 0>(let %a :=@[<hov 2>@ %a@ in@]@ %a@])" + pp_var x pp_term v predicate p + | Pnamed (n, p) -> + fprintf fmt "@[(%s:) %a@]" n predicate p + + +let rec fpp_fields pp_tau tau_of_ctype_logic fmt = function + | [] -> () + | [f] -> Format.fprintf fmt "%s@,:@,%a@\n" (field f) pp_tau + (tau_of_ctype_logic f.Cil_types.ftype) + | f::m -> + Format.fprintf fmt "%s@,:@,%a;@\n" (field f) pp_tau + (tau_of_ctype_logic f.Cil_types.ftype); + fpp_fields pp_tau tau_of_ctype_logic fmt m + +let pp_param pp_tau fmt x = + Format.fprintf fmt "%a:%a" pp_var x pp_tau (Fol.Var.var_type x) + +let fpp_item predicate pp_tau tau_of_ctype_logic pp_term fmt x = + function + | Formula.Cons k -> + fprintf fmt "Definition %s:Z:= %d.@\n" x k + | Formula.Function ([], t) -> + fprintf fmt "Parameter %s: %a.@\n" x pp_tau t + | Formula.Function (tl, t) -> + fprintf fmt "Parameter %s: @[<hov 0>%a -> %a@].@\n" x (pp_typelist pp_tau) tl pp_tau t + | Formula.Predicate [] -> + fprintf fmt "Parameter %s: Prop.@\n" x + | Formula.Predicate tl -> + fprintf fmt "Parameter %s: @[<hov 0>%a -> Prop.@]@\n" x (pp_typelist pp_tau) tl + | Formula.FunctionDef (xs,tr,exp) -> + Format.fprintf fmt "@[<hv 2>Definition %s (%a) : %a :=@ @[<hov 0>%a.@]@]@\n" + x (pp_list (pp_param pp_tau)) xs pp_tau tr pp_term exp + | Formula.PredicateDef (xs,prop) -> + Format.fprintf fmt "@[<hv 2>Definition %s (%a): Prop :=@ @[<hov 0>%a.@]@]@\n" + x (pp_list (pp_param pp_tau)) xs predicate prop + | Formula.Axiom p -> + begin + match Fol_norm.compile p with + | Pred p' -> fprintf fmt "@[<hv 2>Axiom %s:@ %a.@\n@]@\n" x predicate p' + | Conv (defs,p') -> + fpp_lf_let pp_tau pp_term fmt defs ; + fprintf fmt "@[<hv 2>Axiom %s:@ %a.@\n@]@\n" x predicate p' + end + | Formula.Type 0 -> + fprintf fmt "Definition %s:=Set.@\n" x + | Formula.Type n -> + fprintf fmt "@[<hov 2>Definition %s:=Set" x; + for k=1 to n do fprintf fmt " -> Set" done ; + fprintf fmt ".@]@\n" + | Formula.Trecord c -> + let rname = String.capitalize c.Cil_types.cname in + if c.Cil_types.cstruct then + begin + fprintf fmt "@[<hov 2> Record %s : Set := mk%s@\n" rname rname ; + fprintf fmt "{ @\n" ; + fpp_fields pp_tau tau_of_ctype_logic fmt c.Cil_types.cfields ; + fprintf fmt "}.@]@\n" + end + else + begin + fprintf fmt "@[<hov 2> Definition %s:=Set.@\n" rname; + let l = c.Cil_types.cfields in + List.iter (fun f -> + let fd = field f in + let t = tau_of_ctype_logic f.Cil_types.ftype in + Format.pp_print_newline fmt () ; + fprintf fmt "Parameter %s: %s -> %a.@\n " + (get_ufield f) rname pp_tau t; + Format.pp_print_newline fmt () ; + fprintf fmt "Parameter %s: %s -> %a -> %s.@\n " + (set_ufield f) rname pp_tau t rname; + Format.pp_print_newline fmt () ; + fprintf fmt "Axiom get_set_same_%s:@\n" fd; + fprintf fmt " forall r v, %s (%s r v) = v.@\n" + (get_ufield f) (set_ufield f) + ) l + + end + + + +let fpp_header fmt d = + begin + d.d_title fmt ; + Format.pp_print_newline fmt () ; + ( match d.d_source with + | Some { Lexing.pos_fname=f ; Lexing.pos_lnum=k } -> + Format.fprintf fmt "%s:%d: " f k + | None -> () ) ; + d.d_descr fmt ; + end + +let fpp_decl predicate pp_tau tau_of_ctype_logic pp_term fmt d = + begin + fpp_header fmt d ; + Format.pp_print_newline fmt () ; + fpp_item predicate pp_tau tau_of_ctype_logic pp_term fmt d.d_name d.d_item ; + Format.pp_print_newline fmt () ; + end + +let fpp_goal predicate fmt x p = + fprintf fmt "@[<hv 2>Lemma %s:@ %a.@]@." x predicate p + + +module ECoq(L:sig val tau_of_ctype_logic : Cil_types.typ -> Formula.tau end) = +struct + +type pred = Fol.pred +type decl = Fol.decl + +let rec export_tau fmt = function + | Integer -> pp_print_string fmt "Z" + | Real -> pp_print_string fmt "R" + | Boolean -> pp_print_string fmt "bool" + | Pointer t -> export_tau fmt t + | Record c -> + let rname = String.capitalize c.Cil_types.cname in + Format.fprintf fmt "%s" rname + | Array arr -> + Format.fprintf fmt "(array %a)" + export_tau (L.tau_of_ctype_logic arr.Ctypes.arr_element) + | Set te -> + Format.fprintf fmt "(set %a)" export_tau te + | ADT(s,[]) -> pp_print_string fmt s + | ADT("farray",[t]) -> Format.fprintf fmt "(array %a)" export_tau t + | ADT(s,[t]) -> Format.fprintf fmt "(%s %a)" s export_tau t + | ADT(s,t::ts) -> + Format.fprintf fmt "@ (%s " s; + Format.fprintf fmt "@ %a " export_tau t ; + List.iter (fun t -> Format.fprintf fmt "@ %a" export_tau t) ts; + Format.fprintf fmt ")" + + +let rec export_term fmt t = fpp_term export_term fmt t + +let rec pp_pred_atom fmt p = + epp_pred_atom { + pp_type = export_tau; + pp_term = export_term ; + pp_pred = pp_pred_atom; + } fmt p + +let export_pred fmt p = + epp_pred_vbox { + pp_type = export_tau; + pp_term = export_term ; + pp_pred = pp_pred_atom; + } fmt p + +let export_item fmt name item = fpp_item export_pred export_tau fmt name item + +let export_section fmt title = + begin + Format.fprintf fmt "(----------------------------------------)@\n" ; + Format.fprintf fmt "(--- %-32s --- )@\n" title ; + Format.fprintf fmt "(----------------------------------------)@\n" ; + end + +let export_decl fmt d = + Pretty_utils.pp_trail fpp_header fmt d ; + Format.pp_print_newline fmt () ; + fpp_item export_pred export_tau L.tau_of_ctype_logic export_term fmt d.d_name d.d_item + +let export_goal fmt x g = + match Fol_norm.compile g with + | Pred p' -> fpp_goal export_pred fmt x p' + | Conv (defs,p') -> + fpp_lf_let export_tau export_term fmt defs ; + fpp_goal export_pred fmt x p' +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_decl.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_decl.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_decl.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_decl.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,201 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Linked identifiers --- ) +( -------------------------------------------------------------------------- ) + +let mk_empty = "empty" +let mk_singleton = "singleton" +let mk_union = "union" +let mk_inter = "inter" +let mk_remove = "remove" + +let mk_range = "range" +let mk_range_inf = "range_inf" +let mk_range_sup = "range_sup" +let mk_integers = "integers_set" +let mk_radd = "plus_int" +let mk_rmult = "mult_int" +let mk_rneg = "neg_int" + +let set_range_index = "set_range_index" + + +let mk_imodulo i = Pretty_utils.sfprintf "as_%a" Ctypes.pp_int i +let mk_iguard i = Pretty_utils.sfprintf "is_%a" Ctypes.pp_int i + + +let mk_fguard f = Pretty_utils.sfprintf "is_%a" Ctypes.pp_float f + +( -------------------------------------------------------------------------- ) +( --- PRELUDE.why --- ) +( -------------------------------------------------------------------------- ) + +let neg_int = "neg_int" +let add_int = "add_int" +let sub_int = "sub_int" +let mul_int = "mul_int" +let div_int = "computer_div" +let mod_int = "computer_mod" +let eq_int = "eq" +let ne_int = "neq" +let lt_int = "lt_int" +let le_int = "le_int" + +( -------------------------------------------------------------------------- ) +( --- BOOL.why --- ) +( -------------------------------------------------------------------------- ) + +let bool_not = "bool_not" +let bool_and = "bool_and" +let bool_or = "bool_or" + +( -------------------------------------------------------------------------- ) +( --- INTEGERS.why --- ) +( -------------------------------------------------------------------------- ) + +let eq_int_bool = "eq_int_bool" +let ne_int_bool = "neq_int_bool" +let lt_int_bool = "lt_int_bool" +let le_int_bool = "le_int_bool" + +( -------------------------------------------------------------------------- ) +( --- REAL.why --- ) +( -------------------------------------------------------------------------- ) + +let neg_real = "neg_real" +let add_real = "add_real" +let sub_real = "sub_real" +let mul_real = "mul_real" +let fract_real = "div_real" + +let eq_real_bool = "eq_real_bool" +let ne_real_bool = "neq_real_bool" +let lt_real_bool = "lt_real_bool" +let le_real_bool = "le_real_bool" + +let eq_real = "eq_real" +let ne_real = "neq_real" +let lt_real = "lt_real" +let le_real = "le_real" + +let integer_of_real = "truncate_real_to_int" +let real_of_integer = "real_of_int" + +( -------------------------------------------------------------------------- ) +( --- Lexically correct identifiers and reserved Prefixes --- ) +( -------------------------------------------------------------------------- ) + +let identifier x = + let range a c b = a <= c && c <= b in + let buffer = Buffer.create 80 in + for i=0 to String.length x - 1 do + let c = x.[i] in + if range 'a' c 'z' + || range 'A' c 'Z' + || (i > 0 && range '0' c '9') + || c = '_' + then + Buffer.add_char buffer c ; + done ; + Buffer.contents buffer + +( Does not need to be projectified but could be. ) + +let reserved_prefix_tbl = Hashtbl.create 17 +let register_prefix s = + Hashtbl.replace reserved_prefix_tbl s () +let has_reserved_prefix name = + try + let index = String.index name '_' in + let prefix = String.sub name 0 index in + Hashtbl.mem reserved_prefix_tbl prefix + with Not_found -> false + +( --------------------------------------------------------------------- ) +( --- Pure Type Conversions --- ) +( --------------------------------------------------------------------- ) + +open Cil_types +open Format +open Ctypes + +module Tau = +struct +( These pretty print functions are just for pretty print and debugs - file fol_pretty and + F.pp_tau for debug ;) ) + + let tau_of_object = function + | C_int _ -> Formula.Integer + | C_float _ -> Formula.Real + | C_pointer _ -> Formula.Pointer Formula.Integer (useless and non sense value ) + | C_comp c -> Formula.Record c + | C_array a -> Formula.Array a + + let tau_of_ctype_logic t = tau_of_object (object_of t) + + let rec pp_tau fmt = function + | Formula.Integer -> pp_print_string fmt "int" + | Formula.Real -> pp_print_string fmt "real" + | Formula.Boolean -> pp_print_string fmt "bool" + | Formula.Pointer _ -> pp_print_string fmt "pointer" + | Formula.Record c -> Format.fprintf fmt "%s" c.Cil_types.cname + | Formula.Array a -> + Format.fprintf fmt "%a farray" pp_tau + (tau_of_object (object_of a.arr_element)) + | Formula.Set te -> + if Wp_parameters.verbose_atleast 2 + then Format.fprintf fmt "%a set" pp_tau te + else pp_print_string fmt "set" + | Formula.ADT(s,[]) -> pp_print_string fmt s + | Formula.ADT(s,[t]) -> Format.fprintf fmt "%a %s" pp_tau t s + | Formula.ADT(s,t::ts) -> + Format.fprintf fmt "@[(%a" pp_tau t ; + List.iter (fun t -> Format.fprintf fmt ",@,%a" pp_tau t) ts ; + Format.fprintf fmt ") %s@]" s + + + let tau_of_ctype t = tau_of_object (Ctypes.object_of t) + + let name_of_adt = ref (fun lt -> Printf.sprintf "<%s>" lt.lt_name) + + let rec tau_of_logic_type = function + | Ctype c -> tau_of_object (object_of c) + | Linteger -> Formula.Integer + | Lreal -> Formula.Real + | Ltype( d , [] ) when d.lt_name = Utf8_logic.boolean -> Formula.Boolean + | Ltype( {lt_name="set"} , [t] ) -> Formula.Set (tau_of_logic_type t) + | Ltype( lt , ts) -> + let d = !name_of_adt lt in + Formula.ADT (d,List.map tau_of_logic_type ts) + | Lvar _ -> Wp_parameters.not_yet_implemented "logic type variables" + | Larrow _ -> Wp_parameters.not_yet_implemented "type of logic function" + +end + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_eqs.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_eqs.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_eqs.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_eqs.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,103 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ ) +( --- Remove let with unversally quantified variables ) +( ------------------------------------------------------------------------ ) + +open Fol + +module Smap = Datatype.String.Map + +let fresh global sigma x = + let base = Var.basename x in + let tau = Var.var_type x in + let k = try Smap.find base !global with Not_found -> 0 in + let v = Var.ident_named_var base k tau in + global := Smap.add base (succ k) !global ; + v , Vmap.add x (e_var v) sigma + +let alpha sigma x = + try Vmap.find x sigma + with Not_found -> Wp_parameters.fatal "Unbound fol-variable %s (eqs)" (Var.var_name x) + + +( -------------------------------------------------------------------------- ) +( --- Removal of lets --- ) +( -------------------------------------------------------------------------- *) + +let rec term global defs sigma = function + | Tconst _ as c -> c + | Tvar v -> alpha sigma v + | Tgetfield(f,r) -> e_getfield f (term global defs sigma r) + | Tsetfield(f,r,v) -> e_setfield f (term global defs sigma r) (term global defs sigma v) + | Taccess(t,i) -> e_access (term global defs sigma t) (term global defs sigma i) + | Tupdate(t,i,v) -> e_update (term global defs sigma t) (term global defs sigma i) (term global defs sigma v) + | Tapp (n,tl) -> e_app n (List.map (term global defs sigma) tl) + | Tif (t1,t2,t3) -> e_if (term global defs sigma t1) (term global defs sigma t2) (term global defs sigma t3) + | Tlet (x,v,t) -> + let v = term global defs sigma v in + let x,sigma = fresh global sigma x in + defs := (x,v) :: !defs ; + term global defs sigma t + +let flush defs p = + List.fold_left + (fun p (x,_) -> p_forall x p) + (List.fold_left + (fun p (x,v) -> + p_implies (p_eq (e_var x) v) p + ) p defs) + defs + +let rec pred global sigma = function + | Ptrue -> Ptrue + | Pfalse -> Pfalse + | Pimplies(p,q) -> p_implies (pred global sigma p) (pred global sigma q) + | Pand(p,q) -> p_and (pred global sigma p) (pred global sigma q) + | Por(p,q) -> p_or (pred global sigma p) (pred global sigma q) + | Piff(p,q) -> p_iff (pred global sigma p) (pred global sigma q) + | Pnot p -> p_not (pred global sigma p) + | Pnamed(a,p) -> p_named a (pred global sigma p) + | Pforall(x,p) -> let x,sigma = fresh global sigma x in p_forall x (pred global sigma p) + | Pexists(x,p) -> let x,sigma = fresh global sigma x in p_exists x (pred global sigma p) + + | Papp(f,es) -> + let defs = ref [] in + let es = List.map (term global defs sigma) es in + flush !defs (p_app f es) + + | Pif(e,p,q) -> + let defs = ref [] in + let e = term global defs sigma e in + let p = pred global sigma p in + let q = pred global sigma q in + flush !defs (p_if e p q) + + | Plet(x,v,p) -> + let defs = ref [] in + let v = term global defs sigma v in + let x,sigma = fresh global sigma x in + let p = pred global sigma p in + flush ( (x,v)::!defs ) p + +let compile p = pred (ref Smap.empty) Vmap.empty p diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_ergo.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_ergo.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_ergo.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_ergo.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,452 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + + +open Format + +(* -------------------------------------------------------------------------- ) +( --- Alt-ergo Export --- ) +( -------------------------------------------------------------------------- ) + +let get_field f = "get_"^(f.Cil_types.fname)^"_"^(f.Cil_types.fcomp.Cil_types.cname) +let set_field f = "set_"^(f.Cil_types.fname)^"_"^(f.Cil_types.fcomp.Cil_types.cname) + + +let constant fmt = function + | Fol.ConstInt n -> + if n.[0] = '-' + then Format.fprintf fmt "(%s)" n + else pp_print_string fmt n + | Fol.ConstBool b -> pp_print_string fmt (if b then "true" else "false") + | Fol.ConstUnit -> pp_print_string fmt "void" + | Fol.ConstFloat f -> + if f.[0] = '-' + then Format.fprintf fmt "(%s)" f + else pp_print_string fmt f + +let pp_list pp fmt = function + | [] -> () + | x::xs -> + pp fmt x ; + List.iter (fun x -> fprintf fmt ",@,%a" pp x) xs + +let pp_flow fmt nil op pp = function + | [] -> + pp_print_string fmt nil + | x::xs -> + fprintf fmt "@[<hov 1>(%a" pp x ; + List.iter (fun x -> fprintf fmt "@,%s%a" op pp x) xs ; + fprintf fmt ")@]" + +let pp_block fmt tab op pp ps = + match ps with + | [] -> () + | p::ps -> + fprintf fmt "%s %a" tab pp p ; + List.iter (fun p -> fprintf fmt "@\n%s %a" op pp p) ps + +let pp_var fmt v = + let name = Fol_decl.identifier (Fol.Var.var_name v) in + fprintf fmt "%s" name + +let rec collect_assoc op xs = function + | [] -> List.rev xs + | Fol.Tapp(id,ts) :: others when id = op -> + collect_assoc op (collect_assoc op xs ts) others + | t::others -> + collect_assoc op (t::xs) others + +let rec fpp_term fmt t = + match t with + | Fol.Tconst c -> constant fmt c + | Fol.Tvar v -> pp_var fmt v + | Fol.Tapp (id, []) -> pp_print_string fmt id + | Fol.Tapp ("ite",[c;a;b]) | Fol.Tif (c,a,b) -> + fprintf fmt "(@[<v 0>if %a@ then %a@ else %a@])" + fpp_term c fpp_term a fpp_term b + + ( INT ) + | Fol.Tapp ("neg_int", [t]) -> + fprintf fmt "@[<hov 1>(-%a)@]" fpp_term t + | Fol.Tapp ("add_int", ts) -> + let xs = collect_assoc "add_int" [] ts in + pp_flow fmt "0" "+" fpp_term xs + | Fol.Tapp ("sub_int", [a;b]) -> + fprintf fmt "@[<hov 1>(%a@,-%a)@]" fpp_term a fpp_term b + | Fol.Tapp ("mul_int", ts) -> + let xs = collect_assoc "mul_int" [] ts in + pp_flow fmt "1" "" fpp_term xs + + (* REAL ) + | Fol.Tapp ("neg_real", [t]) -> + fprintf fmt "@[<hov 1>(-%a)@]" fpp_term t + | Fol.Tapp ("add_real", ts) -> + let xs = collect_assoc "add_real" [] ts in + pp_flow fmt "0.0" "+" fpp_term xs + | Fol.Tapp ("sub_real", [a;b]) -> + fprintf fmt "@[<hov 1>(%a@,-%a)@]" fpp_term a fpp_term b + | Fol.Tapp ("mul_real", ts) -> + let xs = collect_assoc "mul_real" [] ts in + pp_flow fmt "1.0" "" fpp_term xs + | Fol.Tapp ("div_real", [a;b]) -> + fprintf fmt "@[<hov 1>(%a@,/%a)@]" fpp_term a fpp_term b + + (* OTHER ) + | Fol.Taccess(a,k) -> + Format.fprintf fmt "@[<hv 2>%a[%a]@]" fpp_term a fpp_term k + | Fol.Tupdate(a,k,b) -> + Format.fprintf fmt "@[<hv 2>%a[%a@,<-%a]@]" + fpp_term a fpp_term k fpp_term b + | Fol.Tgetfield(f,r) -> + Format.fprintf fmt "@[<hv 2>%s(%a)@]" (get_field f) fpp_term r + | Fol.Tsetfield(f,r,v) -> + Format.fprintf fmt "@[<hv 2>%s(%a,%a)@]" (set_field f) fpp_term r fpp_term v + | Fol.Tapp (id, t::ts) -> + fprintf fmt "@[<hov 2>%s(@,%a" id fpp_term t ; + List.iter (fun t -> fprintf fmt ",@,%a" fpp_term t) ts ; + fprintf fmt ")@]" + | Fol.Tlet (x,v,t) -> + fprintf fmt "(@[<hov 0>let %a=%a in@ %a@])" + pp_var x fpp_term v fpp_term t + +let rec collect_or ps = function + | Fol.Por(a,b) -> collect_or (collect_or ps b) a + | p -> p :: ps + +let rec collect_and ps = function + | Fol.Pand(a,b) -> collect_and (collect_and ps b) a + | p -> p :: ps + +let rec collect_imply ps = function + | Fol.Pimplies(a,b) -> collect_and (collect_imply ps b) a + | p -> p :: ps + +let rec collect_iff ps = function + | Fol.Piff(a,b) -> collect_iff (collect_iff ps b) a + | p -> p :: ps + + +type 'a pp = Format.formatter -> 'a -> unit +type pp_env = { + pp_type : Formula.tau pp ; + pp_term : Fol.term pp ; + pp_pred : Fol.pred pp ; +} + +open Fol_cc + +let rec export_tau tau_of_ctype_logic fmt = function + | Formula.Integer -> pp_print_string fmt "int" + | Formula.Real -> pp_print_string fmt "real" + | Formula.Boolean -> pp_print_string fmt "bool" + | Formula.Pointer t -> (export_tau tau_of_ctype_logic) fmt t + | Formula.Record c -> Format.fprintf fmt "%s" c.Cil_types.cname + | Formula.Array arr -> + let t = tau_of_ctype_logic arr.Ctypes.arr_element in + Format.fprintf fmt "%a farray" (export_tau tau_of_ctype_logic) t + | Formula.Set te -> + Format.fprintf fmt "%a set" (export_tau tau_of_ctype_logic) te + | Formula.ADT("farray",[t]) -> + Format.fprintf fmt "%a farray" (export_tau tau_of_ctype_logic) t + | Formula.ADT(s,[]) -> pp_print_string fmt s + | Formula.ADT(s,[t]) -> Format.fprintf fmt "%a %s" (export_tau tau_of_ctype_logic) t s + | Formula.ADT(s,t::ts) -> + Format.fprintf fmt "@[(%a"(export_tau tau_of_ctype_logic) t ; + List.iter (fun t -> Format.fprintf fmt ",@,%a" ( export_tau tau_of_ctype_logic) t) ts ; + Format.fprintf fmt ") %s@]" s + + +let pp_args tau_of_ctype_logic fmt = function + | [] -> () + | [x] -> Format.fprintf fmt "(%a@,:@,%a)@,:%a@,=@," + pp_var x (export_tau tau_of_ctype_logic) (Fol.Var.var_type x) + (export_tau tau_of_ctype_logic) (Fol.Var.var_type x) + | x::m -> + Format.fprintf fmt "(%a@,:@,%a@," + pp_var x (export_tau tau_of_ctype_logic) (Fol.Var.var_type x); + List.iter (fun x -> Format.fprintf fmt ",@,%a@,:@,%a@," + pp_var x (export_tau tau_of_ctype_logic) (Fol.Var.var_type x) ) m; + Format.fprintf fmt ")@,:%a@,=@\n" (export_tau tau_of_ctype_logic) (Fol.Var.var_type x) + +let fpp_f_let tau_of_ctype_logic fmt fl = + Format.fprintf fmt "@[<hov 2>function %s@,%a%a@]" + fl.name (pp_args tau_of_ctype_logic) fl.param + fpp_term fl.body + +let fpp_lf_let tau_of_ctype_logic fmt = function + | [] -> () + | x::xs -> + let pp = fpp_f_let tau_of_ctype_logic in + pp fmt x ; + List.iter (fun x -> fprintf fmt "%a@\n" pp x ) xs + + +let rec epp_pred_vbox env fmt p = + match p with + | Fol.Pand _ -> pp_block fmt " " "and" env.pp_pred (collect_and [] p) + | Fol.Por _ -> pp_block fmt " " "or" env.pp_pred (collect_or [] p) + | Fol.Pimplies _ -> pp_block fmt " " "->" env.pp_pred (collect_imply [] p) + | Fol.Piff _ -> pp_block fmt " " "<->" env.pp_pred (collect_iff [] p) + | Fol.Pforall(x,p) -> + fprintf fmt "forall %a:%a.@\n" pp_var x env.pp_type (Fol.Var.var_type x) ; + epp_pred_vbox env fmt p + | Fol.Pexists(x,p) -> + fprintf fmt "exists %a:%a.@\n" pp_var x env.pp_type (Fol.Var.var_type x) ; + epp_pred_vbox env fmt p + |Fol.Pif(t,p,q) -> + fprintf fmt "@[<hov 0>if @[<hov 2>%a@]@ then@]@\n %a@\nelse@\n %a" + env.pp_term t env.pp_pred p env.pp_pred q + | (Fol.Ptrue | Fol.Pfalse | Fol.Papp _ | Fol.Pnot _ | Fol.Pnamed _) -> + env.pp_pred fmt p + | Fol.Plet(x,t,p) -> + fprintf fmt "let %a = @[%a@] in@\n" pp_var x env.pp_term t ; + epp_pred_vbox env fmt p + +(TODO : ensures that label are different from keywords of the host language) +let tag_named tag = "tag_"^tag + + +let rec epp_pred_atom env fmt p = + match p with + | Fol.Pand _ | Fol.Por _ | Fol.Pimplies _ | Fol.Piff _ | Fol.Pif _ + | Fol.Pforall _ | Fol.Pexists _ | Fol.Plet _ -> + fprintf fmt "@[<v 1>(%a)@]" (epp_pred_vbox env) p + | Fol.Pnot p -> + fprintf fmt "@[<hov 2>(not@ %a)@]" (epp_pred_atom env) p + | Fol.Pnamed(tag,p) -> + fprintf fmt "@[<hov 0>%s:@,%a@]" (tag_named tag) (epp_pred_atom env) p + | Fol.Ptrue -> pp_print_string fmt "true" + | Fol.Pfalse -> pp_print_string fmt "false" + | Fol.Papp(id,[]) -> pp_print_string fmt id + | Fol.Papp (("eq" | "eq_int" | "eq_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ =@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp (("neq" | "neq_int" |"neq_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ <>@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp (("lt_int"| "lt_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ <@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp (("le_int"|"le_real"), [t1; t2]) -> + fprintf fmt "@[<hov 1>(%a@ <=@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp(id,t::ts) -> + fprintf fmt "@[<hov 2>%s(@,%a" id env.pp_term t ; + List.iter (fun t -> fprintf fmt ",@ %a" env.pp_term t) ts ; + fprintf fmt ")@]" + +let fpp_pred predicate tau_of_ctype_logic fmt p = + match p with + | Fol.Ptrue -> fprintf fmt "true" + | Fol.Pfalse -> fprintf fmt "false" + | Fol.Papp (id, [])-> fprintf fmt "%s" id + | Fol.Papp ("eq", [t1; t2]) -> fprintf fmt "(%a =@ %a)" fpp_term t1 fpp_term t2 + | Fol.Papp ("neq", [t1; t2]) -> fprintf fmt "(%a <>@ %a)" fpp_term t1 fpp_term t2 + | Fol.Papp (id, l) -> fprintf fmt "@[%s(%a)@]" id (pp_list fpp_term) l + | Fol.Pimplies (a, b) -> fprintf fmt "(@[%a ->@ %a@])" predicate a predicate b + | Fol.Piff (a, b) -> fprintf fmt "(@[%a <->@ %a@])" predicate a predicate b + | Fol.Pand (a, b) -> fprintf fmt "(@[%a and@ %a@])" predicate a predicate b + | Fol.Por (a, b) -> fprintf fmt "(@[%a or@ %a@])" predicate a predicate b + | Fol.Pnot a -> fprintf fmt "(not %a)" predicate a + | Fol.Pif (a, b, c) -> + fprintf fmt "(@[if %a then@ %a else@ %a@])" + fpp_term a predicate b predicate c + | Fol.Pforall (v,p) -> + fprintf fmt "@[<hov 0>(forall %a:%a.@ %a@])" + pp_var v (export_tau tau_of_ctype_logic) (Fol.Var.var_type v) predicate p + | Fol.Pexists (v,p) -> + fprintf fmt "@[<hov 0>(exists %a:%a.@ %a@])" + pp_var v(export_tau tau_of_ctype_logic) (Fol.Var.var_type v) predicate p + | Fol.Plet (x,v,p) -> + fprintf fmt "@[<hov 0>(let %a=%a in@ %a@])" + pp_var x fpp_term v predicate p + | Fol.Pnamed (n, p) -> + fprintf fmt "@[%s: %a@]" (tag_named n) predicate p + +let export_get_set_field tau_of_ctype_logic fmt f = + let cn = f.Cil_types.fcomp.Cil_types.cname in + let fn = tau_of_ctype_logic f.Cil_types.ftype in + let get_f = get_field f in + let set_f = set_field f in + Format.fprintf fmt "logic %s: %s -> %a @\n" + get_f cn (export_tau tau_of_ctype_logic) fn; + Format.fprintf fmt "logic %s: %s , %a -> %s @\n" set_f cn + (export_tau tau_of_ctype_logic) fn cn + + +let export_get_set_other tau_of_ctype_logic fmt f get_f g = + let set_g = set_field g in + Format.pp_print_newline fmt () ; + Format.fprintf fmt + "( Definition of the commutativity of the get field %s over the set field %s)@\n" + f.Cil_types.fname g.Cil_types.fname; + Format.pp_print_newline fmt () ; + Format.fprintf fmt "axiom GetSetOther_%s_%s@,:@\n" f.Cil_types.fname g.Cil_types.fname; + Format.fprintf fmt "forall r:%s.@,forall v:%a.@\n" + f.Cil_types.fcomp.Cil_types.cname + (export_tau tau_of_ctype_logic) (tau_of_ctype_logic g.Cil_types.ftype); + Format.fprintf fmt "%s(%s(r,v))@,=@, %s(r)@\n" get_f set_g get_f; + Format.pp_print_newline fmt () + +let export_generated_axiomatics tau_of_ctype_logic fmt f = + let get_f = get_field f in + let set_f = set_field f in + Format.fprintf fmt + "( Definition of the good properties of the field %s)@\n" f.Cil_types.fname; + Format.pp_print_newline fmt () ; + Format.fprintf fmt "axiom GetSetSame_%s@,:@\n" f.Cil_types.fname; + Format.fprintf fmt "forall r:%s.@,forall v:%a.@\n" + f.Cil_types.fcomp.Cil_types.cname + (export_tau tau_of_ctype_logic) (tau_of_ctype_logic f.Cil_types.ftype); + Format.fprintf fmt "%s(%s(r,v))@,=@, v@\n" get_f set_f ; + Format.pp_print_newline fmt () ; + if f.Cil_types.fcomp.Cil_types.cstruct then + (List.iter (fun g -> + if Cil_datatype.Fieldinfo.equal f g then () else + export_get_set_other tau_of_ctype_logic fmt f get_f g ) + f.Cil_types.fcomp.Cil_types.cfields ;) + else (); + Format.pp_print_newline fmt () ; + Format.pp_print_newline fmt () + +let pp_param tau_of_ctype_logic fmt x = + Format.fprintf fmt "%a:%a" pp_var x (export_tau tau_of_ctype_logic) (Fol.Var.var_type x) + +let fpp_item term predicate tau_of_ctype_logic fmt x = + function + | Formula.Cons k -> + fprintf fmt "function %s (): int = %d@\n" x k + | Formula.Function ([], t) -> + fprintf fmt "logic %s: %a@\n" x (export_tau tau_of_ctype_logic) t + | Formula.Function (tl, t) -> + fprintf fmt "logic %s: @[<hov 0>%a -> %a@]@\n" x + (pp_list (export_tau tau_of_ctype_logic) ) tl (export_tau tau_of_ctype_logic) t + | Formula.Predicate [] -> + fprintf fmt "logic %s: prop@\n" x + | Formula.Predicate tl -> + fprintf fmt "logic %s: @[<hov 0>%a -> prop@]@\n" x + (pp_list (export_tau tau_of_ctype_logic)) tl + | Formula.FunctionDef (xs,tr,exp) -> + Format.fprintf fmt "@[<hv 2>function %s (%a) : %a =@ @[<hov 0>%a@]@]@\n" + x (pp_list (pp_param tau_of_ctype_logic)) xs (export_tau tau_of_ctype_logic) tr term exp + | Formula.PredicateDef (xs,prop) -> + Format.fprintf fmt "@[<hv 2>predicate %s (%a) =@ @[<hov 0>%a@]@]@\n" + x (pp_list (pp_param tau_of_ctype_logic)) xs predicate prop + | Formula.Axiom p -> + begin + match Fol_norm.compile p with + | Fol_norm.Pred p' -> fprintf fmt "@[<hv 2>axiom %s:@ %a@]@\n" x predicate p' + | Fol_norm.Conv (defs,p') -> + fpp_lf_let tau_of_ctype_logic fmt defs ; + fprintf fmt "@[<hv 2>axiom %s:@ %a@]@\n" x predicate p' + end + | Formula.Type 0 -> + fprintf fmt "type %s@\n" x + | Formula.Type 1 -> + fprintf fmt "type 'a %s@\n" x + | Formula.Type n -> + fprintf fmt "@[<hov 2>type ('a" ; + for k=2 to n do + fprintf fmt ",%c" (char_of_int (int_of_char 'a'+k-1)) + done ; + Format.fprintf fmt ") %s@]@\n" x + | Formula.Trecord c -> + begin + Format.fprintf fmt "type %s@\n" c.Cil_types.cname ; + let l = c.Cil_types.cfields in + List.iter (fun f -> export_get_set_field tau_of_ctype_logic fmt f) l ; + List.iter (fun f -> export_generated_axiomatics tau_of_ctype_logic fmt f) l + end + + +let fpp_header fmt d = + begin + d.Formula.d_title fmt ; + Format.pp_print_newline fmt () ; + ( match d.Formula.d_source with + | Some { Lexing.pos_fname=f ; pos_lnum=k } -> + Format.fprintf fmt "%s:%d: " f k + | None -> () ) ; + d.Formula.d_descr fmt ; + end + +let fpp_decl term predicate tau_of_ctype_logic fmt d = + begin + fpp_header fmt d ; + Format.pp_print_newline fmt () ; + fpp_item term predicate tau_of_ctype_logic fmt d.Formula.d_name d.Formula.d_item ; + Format.pp_print_newline fmt () ; + end + +let fpp_goal predicate fmt x p = + fprintf fmt "@[<hv 2>goal %s:@ %a@]@." x predicate p + +let export_term fmt t = fpp_term fmt t + +let rec pp_pred_atom tau_of_ctype_logic fmt p = + epp_pred_atom { + pp_type = export_tau tau_of_ctype_logic; + pp_term = export_term ; + pp_pred = pp_pred_atom tau_of_ctype_logic ; + } fmt p + +let export_pred tau_of_ctype_logic fmt p = + epp_pred_vbox { + pp_type = export_tau tau_of_ctype_logic; + pp_term = export_term ; + pp_pred = pp_pred_atom tau_of_ctype_logic; + } fmt p + +let export_item tau_of_ctype_logic fmt name item = +fpp_item (export_pred tau_of_ctype_logic) fmt name item + +let export_decl tau_of_ctype_logic fmt d = + Pretty_utils.pp_trail fpp_header fmt d ; + Format.pp_print_newline fmt () ; + fpp_item export_term (export_pred tau_of_ctype_logic) tau_of_ctype_logic fmt d.Formula.d_name d.Formula.d_item + +let export_goal tau_of_ctype_logic fmt x g= + match Fol_norm.compile g with + | Fol_norm.Pred p' -> fpp_goal (export_pred tau_of_ctype_logic) fmt x p' + | Fol_norm.Conv (defs,p') -> + fpp_lf_let tau_of_ctype_logic fmt defs ; + fpp_goal (export_pred tau_of_ctype_logic) fmt x p' + + +module Make(L: sig val tau_of_ctype_logic : Cil_types.typ -> Formula.tau end) = +struct + type pred = Fol.pred + type decl = Fol.decl + + let export_section fmt title = + begin + Format.fprintf fmt "(----------------------------------------)@\n" ; + Format.fprintf fmt "(--- %-32s ---)@\n" title ; + Format.fprintf fmt "(----------------------------------------*)@\n" ; + end + + let export_tau fmt t = + export_tau L.tau_of_ctype_logic fmt t + + let export_decl fmt d = + export_decl L.tau_of_ctype_logic fmt d + + let export_goal fmt g p = + export_goal L.tau_of_ctype_logic fmt g p + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_eval.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_eval.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_eval.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_eval.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,80 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Fol + +(* III. let expansion *) + +let new_fname f x sigma cpt = + incr cpt; + let sx = Var.basename x in + let nx = Var.ident_named_var sx !cpt (Var.var_type x) in + nx,(Vmap.add x (f nx) sigma) + +let rec expt sigma = function + | Tlet(x,t1,t2) -> + let t1 = expt sigma t1 in + expt (Vmap.add x t1 sigma) t2 + | Tapp(f,tl) -> + e_app f (List.map (expt sigma) tl) + | Tif (c,ta,tb) -> + e_if (expt sigma c)(expt sigma ta)(expt sigma tb) + | Tconst _ as c -> c + | Taccess(t,i) -> e_access(expt sigma t) (expt sigma i) + | Tupdate(t,i,v) -> e_update(expt sigma t) (expt sigma i) (expt sigma v) + | Tgetfield(f,r) -> e_getfield f (expt sigma r) + | Tsetfield(f,r,v) -> e_setfield f (expt sigma r) (expt sigma v) + | Tvar x as t -> + begin + try Vmap.find x sigma + with Not_found -> t + end + + let rec expp sigma cpt = function + | Pimplies (p1,p2) -> + p_implies (expp sigma cpt p1)(expp sigma cpt p2) + + | Pif (t,p1,p2) -> + p_if (expt sigma t) + (expp sigma cpt p1)(expp sigma cpt p2) + | Pand (p1,p2) -> p_and(expp sigma cpt p1)(expp sigma cpt p2) + | Por (p1,p2) -> p_or(expp sigma cpt p1)(expp sigma cpt p2) + | Piff (p1,p2) -> p_iff (expp sigma cpt p1)(expp sigma cpt p2) + | Pnot p -> p_not (expp sigma cpt p) + | Papp (f, tl) -> p_app f (List.map (expt sigma) tl) + | Pexists(x,p) -> + let nx,sigma = new_fname e_var x sigma cpt in + p_exists nx (expp sigma cpt p) + | Pforall (x,p) -> + let nx,sigma = new_fname e_var x sigma cpt in + p_forall nx (expp sigma cpt p) + | Plet (x,t,p) -> + let t1 = expt sigma t in + expp (Vmap.add x t1 sigma) cpt p + | Pnamed(s,p) -> Pnamed(s,expp sigma cpt p) + | p -> p + + let plet_expansion p = + expp Vmap.empty (ref 0) p + + let elet_expansion t = + expt Vmap.empty t diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_formula.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_formula.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_formula.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_formula.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,1104 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Fol_decl +open Formula + +(* -------------------------------------------------------------------------- ) +( --- OPERATORS --- ) +( -------------------------------------------------------------------------- ) + +let i_pred = function + | Ceq -> eq_int + | Cneq -> ne_int + | Clt -> lt_int + | Cleq -> le_int + +let i_bool = function + | Ceq -> eq_int_bool + | Cneq -> ne_int_bool + | Clt -> lt_int_bool + | Cleq -> le_int_bool + +let i_op = function + | Iadd -> add_int + | Isub -> sub_int + | Imul -> mul_int + | Idiv -> div_int + | Imod -> mod_int + +let r_pred = function + | Ceq -> eq_real + | Cneq -> ne_real + | Clt -> lt_real + | Cleq -> le_real + +let r_bool = function + | Ceq -> eq_real_bool + | Cneq -> ne_real_bool + | Clt -> lt_real_bool + | Cleq -> le_real_bool + +let r_op = function + | Radd -> add_real + | Rsub -> sub_real + | Rmul -> mul_real + | Rdiv -> fract_real + + +type 'a term = Fol.term +type pred = Fol.pred +type decl = Fol.decl + +type abstract = m_abstract term +type integer = m_integer term +type real = m_real term +type boolean = m_boolean term +type record = m_record term +type urecord = m_array term +type array = m_array term +type set = m_set term +type name = m_integer term + +type var = Fol.Var.t + +let e_true = Fol.e_true +let e_false = Fol.e_false + +let e_int k = Fol.e_int k +let e_int64 k = Fol.e_int64 k +let e_float k = Fol.e_float k +let e_icst z = Fol.e_cnst (Fol.c_int_of_str z) +let e_rcst z = Fol.e_cnst (Fol.c_float_of_str z) + +let wrap t = t +let unwrap t = t + +let e_call f ts = Fol.e_app f ts +let p_call f xs = Fol.p_app f xs + +let e_access = Fol.e_access +let e_update = Fol.e_update +let e_getfield = Fol.e_getfield +let e_setfield = Fol.e_setfield + +let unop f a = unwrap (e_call f [wrap a]) +let binop f a b = unwrap (e_call f [wrap a;wrap b]) +let predop f a b = p_call f [wrap a;wrap b] + +let e_ineg = unop neg_int +let e_rneg = unop neg_real + +let e_icmp op = binop (i_bool op) +let p_icmp op = predop (i_pred op) + +let e_rcmp op = binop (r_bool op) +let p_rcmp op = predop (r_pred op) + +let e_iop op = binop (i_op op) +let e_rop op = binop (r_op op) + +let real_of_integer = unop real_of_integer +let integer_of_real = unop integer_of_real + +let a_true = wrap (e_int 1) +let a_false = wrap (e_int 0) + +let e_bool (c : boolean) : integer = + unwrap (e_call "ite" [wrap c;a_true;a_false]) + +let e_cond (c : boolean) (a : 'a term) (b : 'a term) : 'a term = + unwrap (e_call "ite" [wrap c;wrap a;wrap b]) + +let e_not = unop bool_not +let e_and = binop bool_and +let e_or = binop bool_or + +let e_bnot = unop "bnot" +let e_band = binop "band" +let e_bor = binop "bor" +let e_bxor = binop "bxor" +let e_lshift = binop "lshift" +let e_rshift = binop "rshift" + +let i_zero = e_int 0 +let i_one = e_int 1 +let i_sub = e_iop Isub +let i_add = e_iop Iadd +let i_mult = e_iop Imul + +let r_zero = e_float 0.0 + +( --------------------------------------------------------------------- ) +( --- Declaration --- ) +( --------------------------------------------------------------------- ) + +open Cil_types +open Ctypes +open Format + +let rec is_incl_comp c1 c2 = + match object_of c2 with + | C_comp c -> Cil_datatype.Compinfo.equal c1 c || + List.exists (fun t -> is_incl_comp c1 t.ftype) c.cfields + | C_array arr -> is_incl_comp c1 arr.arr_element + | _ -> false + +( Ensures that structures comes in the correct order ) + +let comp_compare c1 c2 = + if (List.exists (fun t -> is_incl_comp c1 t.ftype) c2.cfields) then -1 + else + if (List.exists (fun t -> is_incl_comp c2 t.ftype) c1.cfields) then 1 + else Cil_datatype.Compinfo.compare c1 c2 + +let part_of_item = function + | Formula.Type _ -> 1 + | Formula.Cons _ -> 2 + | Formula.FunctionDef _ + | Formula.PredicateDef _ + | Formula.Function _ + | Formula.Predicate _ -> 3 + | Formula.Axiom _ -> 4 + | Formula.Trecord _ -> 5 + +let compare_item d1 d2 = + let p = part_of_item d1.Formula.d_item - part_of_item d2.Formula.d_item in + if p = 0 then + match d1.Formula.d_item , d2.Formula.d_item with + | Formula.Trecord c1 , Formula.Trecord c2 -> comp_compare c1 c2 + | Formula.Cons i , Formula.Cons j -> i - j + | _ ,_ -> String.compare d1.Formula.d_name d2.Formula.d_name + else p + + +module Dset = Set.Make + (struct + type t = decl + let compare = compare_item + end) + +let gindex : (string,decl) Hashtbl.t = Hashtbl.create 731 +let gfresh = Hashtbl.create 131 + +let fresh_name prefix basename = + let x = identifier basename in + let m = if x="" then prefix else Printf.sprintf "%s_%s" prefix x in + try + let p = Hashtbl.find gfresh m in + incr p ; Printf.sprintf "%s_%d" m !p + with Not_found -> + Hashtbl.add gfresh m (ref 0) ; m + +( order not really import, but they are in order ) + +let s_index = function + | Formula.S_Type -> 0 + | Formula.S_Cons -> 1 + | Formula.S_Logic_Sig -> 2 + | Formula.S_Logic_Def -> 3 + | Formula.S_Logic_Prop -> 4 + | Formula.S_Model_Sig -> 5 + | Formula.S_Model_Def -> 6 + | Formula.S_Model_Prop -> 7 + | Formula.S_User_Sig -> 8 + | Formula.S_User_Prop -> 9 + +let gsection = Array.create 10 Dset.empty + +( order is important, and they are in order ) + +let gtoc = [| + Formula.S_Type , "Type Definitions" ; + Formula.S_Cons , "Type Constructors" ; + Formula.S_Logic_Sig , "Logic Signatures" ; + Formula.S_Logic_Def , "Logic Definitions" ; + Formula.S_Logic_Prop , "Logic Properties" ; + Formula.S_Model_Sig , "Model Signatures" ; + Formula.S_Model_Def , "Model Definitions" ; + Formula.S_Model_Prop , "Model Properties" ; + Formula.S_User_Sig , "User-defined Signatures" ; + Formula.S_User_Prop , "User-defined Properties" ; +|] + +let gclear = ref [] + +let clear () = + begin + Hashtbl.clear gfresh ; + Hashtbl.clear gindex ; + Array.fill gsection 0 (Array.length gsection) Dset.empty ; + List.iter (fun f -> f ()) !gclear ; + end +let on_clear f = gclear := !gclear @ [f] + +let locked = ref false + ( ensures that no declaration has been added during the iteration ) + +let has_declaration = Hashtbl.mem gindex + +let compile_let_item = function + | (Formula.Cons _ | Formula.Type _ + | Formula.Function _ | Formula.Predicate _ | Formula.Trecord _) as item -> item + | Formula.FunctionDef(xs,t,e) -> Formula.FunctionDef(xs,t,Fol_eval.elet_expansion e) + | Formula.PredicateDef(xs,p) -> + let xs,p = Fol_let.compile_def xs p in + Formula.PredicateDef(xs,p) + | Formula.Axiom p -> Formula.Axiom (Fol_let.compile p) + +let compile_let_decl d = + { + Formula.d_section = d.Formula.d_section ; + Formula.d_name = d.Formula.d_name ; + Formula.d_title = d.Formula.d_title ; + Formula.d_descr = d.Formula.d_descr ; + Formula.d_source = d.Formula.d_source ; + Formula.d_item = compile_let_item d.Formula.d_item ; + } + +let rec add_declaration d = + try + Wp_parameters.debug ~dkey:"logic" "Adding declaration %s (%t)@." + d.Formula.d_name d.Formula.d_title ; + if !locked then Wp_parameters.fatal + "Locked datalib (when declaring %t)" d.Formula.d_title ; + let old = Hashtbl.find gindex d.Formula.d_name in + Wp_parameters.fatal + "Duplicate definition for name '%s':@ Old: %t@ New: %t" + d.Formula.d_name old.Formula.d_title d.Formula.d_title + with Not_found -> + begin + Hashtbl.add gindex d.Formula.d_name (compile_let_decl d) ; + let s = s_index d.Formula.d_section in + gsection.(s) <- Dset.add d gsection.(s) + end + +( -------------------------------------------------------------------------- ) +( --- Dependencies for macros --- ) +( -------------------------------------------------------------------------- ) + +open Fol + +module Mset = Datatype.String.Set + +let exported_macros = ref Mset.empty + +let is_macro d = match d.d_item with + | FunctionDef _ | PredicateDef _ -> true + | _ -> false + +let is_macro_section = function + | S_Type | S_Cons + | S_Logic_Sig | S_Logic_Prop + | S_Model_Sig | S_Model_Prop + | S_User_Sig | S_User_Prop -> false + | S_Logic_Def | S_Model_Def -> true + +let rec do_export f d = + export_depends_for_item f d.d_item ; + if not (Mset.mem d.d_name !exported_macros) then + ( f d ; exported_macros := Mset.add d.d_name !exported_macros ) + +and export_depends_for_item f = function + | Type _ | Cons _ | Function _ | Predicate _ | Trecord _ | Axiom _ -> () + | FunctionDef(_,_,exp) -> export_depends_for_term f exp + | PredicateDef(_,prop) -> export_depends_for_pred f prop + +and export_depends_for_name f x = + try + let d = Hashtbl.find gindex x in + if is_macro d then do_export f d + with Not_found -> () + +and export_depends_for_term f = function + | Tconst _ | Tvar _ -> () + | Tapp(x,ts) -> + export_depends_for_name f x ; + List.iter (export_depends_for_term f) ts + | Tgetfield(_,t) -> + export_depends_for_term f t + | Tsetfield(_,t,v) | Taccess(t,v) | Tlet(_,t,v) -> + export_depends_for_term f t ; + export_depends_for_term f v + | Tupdate(t,v,w) | Tif(t,v,w) -> + export_depends_for_term f t ; + export_depends_for_term f v ; + export_depends_for_term f w + +and export_depends_for_pred f = function + | Papp(x,ts) -> + export_depends_for_name f x ; + List.iter (export_depends_for_term f) ts + | Ptrue | Pfalse -> () + | Pimplies(p,q) | Pand(p,q) | Por(p,q) | Piff(p,q) -> + export_depends_for_pred f p ; + export_depends_for_pred f q + | Pif(c,p,q) -> + export_depends_for_term f c ; + export_depends_for_pred f p ; + export_depends_for_pred f q + | Pnot p | Pnamed(_,p) | Pexists(_,p) | Pforall(_,p) -> + export_depends_for_pred f p + | Plet(_,t,p) -> + export_depends_for_term f t ; + export_depends_for_pred f p + +let iter_all section f = + try + locked := true ; + exported_macros := Mset.empty ; + Array.iter + (fun (s,t) -> + let k = s_index s in + if not (Dset.is_empty gsection.(k)) then + begin + let job = if is_macro_section s then do_export f else f in + section t ; Dset.iter job gsection.(k) ; + end + ) gtoc ; + locked := false ; + exported_macros := Mset.empty ; + with e -> + locked := false ; + exported_macros := Mset.empty ; + raise e + +( -------------------------------------------------------------------------- ) +( --- Declaration Functors --- ) +( -------------------------------------------------------------------------- ) + +module type Identifiable = +sig + type t + module H : Hashtbl.S + val index : t -> H.key + val prefix : string + val basename : t -> string + val location : t -> Lexing.position option + val pp_title : Format.formatter -> t -> unit + val pp_descr : Format.formatter -> t -> unit +end + +module type Registry = +sig + type t + val define : t -> unit + val get_definition : t -> Fol.decl + val on_definition : (t -> Fol.decl -> unit) -> unit +end + +module type Declarator = +sig + include Identifiable + val clear : unit -> unit + val section : Formula.section + val declare : t -> string -> (Fol.Var.t,Fol.term,Fol.pred) Formula.item +end + +module DRegister + (D : Declarator) : + (Registry with type t = D.t) = +struct + let () = register_prefix D.prefix + + type t = D.t + let index : Fol.decl D.H.t = D.H.create 131 + let demons : (t -> Fol.decl -> unit) list ref = ref [] + + let () = on_clear (fun () -> D.clear () ; D.H.clear index) + + let get_definition x = + let k = D.index x in + try D.H.find index k + with Not_found -> + let name = fresh_name D.prefix (D.basename x) in + let item = D.declare x name in + let d = { + Formula.d_name = name ; + Formula.d_section = D.section ; + Formula.d_source = D.location x ; + Formula.d_item = item ; + Formula.d_title = (fun fmt -> D.pp_title fmt x) ; + Formula.d_descr = (fun fmt -> D.pp_descr fmt x) ; + } in + add_declaration d ; + D.H.add index k d ; + List.iter (fun f -> f x d) !demons ; + d + + let define x = ignore (get_definition x) + let on_definition f = demons := !demons @ [f] +end + + + +( -------------------------------------------------------------------------- ) +( --- Built-in Identifiables --- ) +( -------------------------------------------------------------------------- ) +let rec pp_dim fmt = function + | TArray (typ_elt,lo,_,_) -> + (match lo with + | Some lo -> + Format.fprintf fmt "[%a]" !Ast_printer.d_exp lo + | None -> + Format.fprintf fmt "[]"); pp_dim fmt typ_elt + | _ -> () + + +let rec pp_ctype dim fmt = function + | TInt(ikind,_) -> Format.fprintf fmt "%a" Cil.d_ikind ikind + | TFloat(fkind,_) -> Format.fprintf fmt "%a" Cil.d_fkind fkind + | TPtr(typ,_) -> Format.fprintf fmt "%a" (pp_ctype dim) typ + | TFun _ as t -> Format.fprintf fmt "%a" (pp_ctype dim) t + | TEnum (e,_) -> Format.fprintf fmt "enum %s " e.ename + | TComp (comp,_,_) -> + Format.fprintf fmt + "%s %s" + (if comp.cstruct then "struct" else "union") + comp.cname + + | TArray (typ_elt,_,_,_) as t -> + pp_ctype false fmt typ_elt ; + if dim then pp_dim fmt t; + + | TBuiltin_va_list _ -> pp_print_string fmt "builtin type" + | TVoid _ -> pp_print_string fmt "void" + | TNamed (t,_) -> Format.fprintf fmt "%s" t.tname + +module Varinfo : Identifiable with type t = varinfo = +struct + type t = varinfo + let prefix = "X" + let index x = x + let basename x = x.vname + let location x = Some(fst x.vdecl) + module H = Cil_datatype.Varinfo.Hashtbl + let pp_title fmt x = + if x.vglob + then Format.fprintf fmt "Global '%a'" !Ast_printer.d_var x + else Format.fprintf fmt "Local '%a'" !Ast_printer.d_var x + let pp_descr fmt x = + Format.fprintf fmt "%a %a ;" + (pp_ctype true) x.vtype !Ast_printer.d_var x +end + +module Varaddr : Identifiable with type t = varinfo = +struct + include Varinfo + let prefix = "A" + let pp_title fmt x = Format.fprintf fmt "Address of '%a'" pp_title x +end + +module Fieldinfo : Identifiable with type t = fieldinfo = +struct + type t = fieldinfo + let prefix = "F" + let index f = f + let basename f = f.fname + let location f = Some(fst f.floc) + module H = Cil_datatype.Fieldinfo.Hashtbl + let pp_title fmt f = Format.fprintf fmt "Field '%s'" f.fname + let pp_descr fmt f = + Format.fprintf fmt "@[<hov 0>@[<hov 2>%s %s {@ ... ;@ %a %s ;@ ...@]@ }@]" + (if f.fcomp.cstruct then "struct" else "union") + f.fcomp.cname + !Ast_printer.d_type f.ftype f.fname +end + +module Compinfo : Identifiable with type t = compinfo = +struct + type t = compinfo + let prefix = "C" + let index c = c + let basename c = c.cname + let location c = + match c.cfields with + | f :: _ -> + let s = fst f.floc in + if s.Lexing.pos_fname = "" then None else Some s + | [] -> None + module H = Cil_datatype.Compinfo.Hashtbl + let pp_title fmt c = + Format.fprintf fmt "%s '%s'" + (if c.cstruct then "Struct" else "Union") c.cname + let pp_descr fmt c = + Format.fprintf fmt "typedef %s %s { ... }" + (if c.cstruct then "struct" else "union") c.cname +end + +module Arrayinfo : Identifiable with type t = arrayinfo = +struct + type t = arrayinfo + let prefix = "A" + module H = Hashtbl.Make(AinfoComparable) + let index a = a + let location _ = None + let basename a = Ctypes.basename (C_array a) + let pp_title fmt a = Ctypes.pretty fmt (C_array a) + let pp_descr fmt _ = Format.fprintf fmt "Logic array" +end + +module LTypeinfo : Identifiable with type t = Cil_types.logic_type = +struct + type t = Cil_types.logic_type + let prefix = "AT" + let index c = c + let basename ty = + let rec typ_basename ty = + match object_of ty with + | C_int i -> Pretty_utils.sfprintf "%a" Ctypes.pp_int i + | C_float f -> Pretty_utils.sfprintf "%a" Ctypes.pp_float f + | C_pointer _ -> "pointer" + | C_comp c -> (if c.cstruct then "struct_" else "union_")^ + c.cname + | C_array arr -> typ_basename arr.Ctypes.arr_element^"_array" + in + match ty with + | Ctype c -> "is_"^typ_basename c + | Linteger | Lreal -> "" + | Lvar x -> x + | Ltype (lt,_) -> lt.lt_name + | Larrow _ ->"" + + let location _ = None + module H = Cil_datatype.Logic_type.Hashtbl + let pp_title fmt _ = + Format.fprintf fmt "Acsl type" + let pp_descr fmt _ = + Format.fprintf fmt "Declaration" +end + +module Logicvar : Identifiable with type t = logic_var = +struct + type t = logic_var + let prefix = "D" + let index x = x + let basename x = x.lv_name + let location _ = None + module H = Cil_datatype.Logic_var.Hashtbl + let pp_title fmt x = Format.fprintf fmt "Logic variable '%s'" x.lv_name + let pp_descr fmt _x = Format.fprintf fmt "Declaration" +end + + +module HC_object = +struct + type t = Ctypes.c_object + let equal = Ctypes.equal + let hash = Ctypes.hash +end + +module Cobject : Identifiable with type t = Ctypes.c_object = +struct + type t = Ctypes.c_object + let prefix = "Ct" + let index t = t + let basename x = Ctypes.basename x + let location _ = None + module H = Hashtbl.Make(HC_object) + let pp_title fmt x = Format.fprintf fmt "C type '%a'" Ctypes.pp_object x + let pp_descr fmt _ = Format.fprintf fmt "Declaration" +end + +module HC_ArrayDim = +struct + type t = Ctypes.c_object int (* object with n-dimensions (number of []) ) + let equal (ta,n) (tb,m) = (n=m) && Ctypes.equal ta tb + let hash (ta,n) = 31n + 73Ctypes.hash ta +end + +module ArrayDim : Identifiable with type t = Ctypes.c_object int = +struct + type t = Ctypes.c_object * int + let prefix = "Ca" + let index t = t + let basename (te,n) = + if n > 1 then Printf.sprintf "%s_d%d" (Ctypes.basename te) n + else Ctypes.basename te + let location _ = None + module H = Hashtbl.Make(HC_ArrayDim) + let pp_title fmt (te,n) = + Format.fprintf fmt "Array %a" Ctypes.pp_object te ; + for i = 1 to n do Format.fprintf fmt "[]" done + let pp_descr fmt _ = Format.fprintf fmt "Declaration" +end + +(* ----------------------------------------------------------------------- ) +( --- User Type Registry --- ) +( ----------------------------------------------------------------------- ) + +module LTinfo = +struct + type t = logic_type_info + let compare t1 t2 = String.compare t1.lt_name t2.lt_name + let hash v = Hashtbl.hash v.lt_name + let equal t1 t2 = t1.lt_name = t2.lt_name +end + +module LTinfoId : Identifiable with type t = logic_type_info = +struct + type t = logic_type_info + let prefix = "T" + let index t = t + let basename c = c.lt_name + let location _c = None + module H = Hashtbl.Make(LTinfo) + let pp_title fmt x = + Format.fprintf fmt "Logic type '%s'" x.lt_name + let pp_descr fmt _x = + Format.fprintf fmt "Declaration" +end + +module ADTDecl = DRegister + (struct + include LTinfoId + let declare t _ = + Formula.Type (List.length t.lt_params) + let section = Formula.S_Type + let clear () = () + end) + +let adt_decl lt = (ADTDecl.get_definition lt).Formula.d_name +let () = Fol_decl.Tau.name_of_adt := adt_decl + +( --------------------------------------------------------------------- ) +( --- HOL --- ) +( --------------------------------------------------------------------- ) + +type pool = (string,int option) Hashtbl.t + +let pool () = Hashtbl.create 7 + +let fresh_var pool basename = + let new_contents = + try + let counter = Hashtbl.find pool basename in + match counter with + | None -> Some 0 + | Some i -> Some (succ i) + with Not_found -> None + in + Hashtbl.replace pool basename new_contents; + new_contents + +let p_fresh pool x kind = + let x = + if Fol_decl.has_reserved_prefix (x^"_") then + let new_name = "G_"^x in + if Fol_decl.has_reserved_prefix new_name then + Wp_parameters.fatal + "Reserved prefix for '%s' is clashing. Frama-C WP plugin cannot reserve the prefix 'G'" + new_name + else new_name + else x + in + let vx = + let tau, ltype = match kind with + | Formula.Model t -> t, None + | Formula.Acsl(t,ty) -> t, Some (ty) + in Fol.Var.mk x (fresh_var pool x) tau ltype + in vx + +let var v = Fol.e_var v + +let tau_of_var = Fol.Var.var_type +let name_of_var = Fol.Var.var_name +let basename_of_var = Fol.Var.basename +let kind_of_var = Fol.Var.kind_of_var + +let p_freshen pool v = p_fresh pool (Fol.Var.basename v) (Fol.Var.kind_of_var v) + +let p_true = Fol.Ptrue +let p_false = Fol.Pfalse + +let p_not a = Fol.p_not a +let p_bool a = Fol.p_eq e_true a + +let equal_terms e1 e2 = Fol.eq_terms e1 e2 + +let p_and a b = Fol.p_and a b +let p_or a b = Fol.p_or a b +let p_xor a b = Fol.p_xor a b +let p_eq a b = Fol.p_eq a b +let p_neq a b = Fol.p_neq a b +let p_iff a b = Fol.p_iff a b +let p_conj l = Fol.p_conj l +let p_disj l = Fol.p_disj l +let p_cond b pt pf = Fol.p_if (wrap b) pt pf +let p_named = Fol.p_named +let is_true = Fol.is_true +let is_false = Fol.is_false + +let eq_var = Fol.Var.equal + +let e_subst alpha x v t = + match v with + | Fol.Tvar y when (Fol.Var.equal x y) -> t ( v is equal to x ) + + | (Fol.Tconst _ | Fol.Tvar _ | Fol.Tapp(_,[])) + when Wp_parameters.Simpl.get () -> + Fol.term_replace alpha x v t + + | _ -> Fol.e_let x v t + +let p_forall xs p = + List.fold_right Fol.p_forall xs p + +let p_exists xs p = + List.fold_right Fol.p_exists xs p + +let p_subst alpha x v p = + match v with + | Fol.Tvar y when (Fol.Var.equal x y) -> p ( v is equal to x ) + + | (Fol.Tconst _ | Fol.Tvar _ | Fol.Tapp(_,[])) + when Wp_parameters.Simpl.get () -> + Fol.pred_replace alpha x v p + + | _ -> Fol.p_let x v p + +let p_implies h p = Fol.p_implies h p + +let rec apply alpha x = match alpha with + | [] -> None + | (y,y')::s -> + if Fol.Var.equal x y then Some y' else apply s x + +let rec e_rename s t = + match t with + | Fol.Tconst _ -> t + | Fol.Tvar x -> + ( match apply s x with + | None -> t + | Some y -> Fol.e_var y ) + | Fol.Tapp(f,ts) -> Fol.e_app f (List.map (e_rename s) ts) + | Fol.Taccess(t,i) -> e_access (e_rename s t) (e_rename s i) + | Fol.Tupdate(t,i,v) -> e_update (e_rename s t) (e_rename s i) (e_rename s v) + | Fol.Tgetfield(f,r) -> e_getfield f (e_rename s r) + | Fol.Tsetfield(f,r,v) -> e_setfield f (e_rename s r) (e_rename s v) + | Fol.Tif(a,b,c) -> Fol.e_if (e_rename s a) (e_rename s b) (e_rename s c) + | Fol.Tlet(y,a,b) -> + let a' = e_rename s a in + let s' = (y,y)::s in ( defensive ! ) + Fol.e_let y a' (e_rename s' b) + +let term_has_var = Fol.e_has_var +let pred_has_var = Fol.p_has_var + +let term_calls = Fol.term_calls +let pred_calls = Fol.pred_calls + +let term_closed t = Fol.e_closed [] t +let pred_closed p = Fol.p_closed [] p + +type alpha = Fol.Var.t Fol.Vmap.t +let empty_alpha = Fol.Vmap.empty +let fold_alpha = Fol.Vmap.fold +let p_more_alpha_cv = Fol.pred_alpha_cv +let p_alpha_cv p = Fol.p_alpha_cv p + + +( -------------------------------------------------------------------------- ) +( --- Free Variables --- ) +( -------------------------------------------------------------------------- ) + + +let rec free_term xs = function + | Tconst _ -> xs + | Tvar x -> Vset.add x xs + | Tapp(_,ts) -> List.fold_left free_term xs ts + | Tgetfield(_,t) -> free_term xs t + | Tsetfield(_,t,t') | Taccess(t,t') -> free_term (free_term xs t) t' + | Tupdate(t1,t2,t3) | Tif(t1,t2,t3) -> free_term (free_term (free_term xs t1) t2) t3 + | Tlet(x,a,b) -> + if Vset.mem x xs then + free_term (free_term xs b) a + else + free_term (Vset.remove x (free_term xs b)) a + +let rec free_pred xs = function + | Papp(_,ts) -> List.fold_left free_term xs ts + | Ptrue | Pfalse -> xs + | Pimplies(p,q) | Pand(p,q) | Por(p,q) | Piff(p,q) -> free_pred (free_pred xs p) q + | Pnot p | Pnamed(_,p) -> free_pred xs p + | Pif(a,p,q) -> free_pred (free_pred (free_term xs a) p) q + | Plet(x,t,p) -> + if Vset.mem x xs then + free_term (free_pred xs p) t + else + free_term (Vset.remove x (free_pred xs p)) t + | Pexists(x,p) | Pforall(x,p) -> + if Vset.mem x xs then + free_pred xs p + else + Vset.remove x (free_pred xs p) + +let freevars p = Vset.elements (free_pred Vset.empty p) + +( -------------------------------------------------------------------------- ) +( --- Pretty Print --- ) +( -------------------------------------------------------------------------- ) + +let rec pp_term fmt t = Fol_pretty.fpretty_term pp_term fmt t + +let () = Fol.pp_term := pp_term + +(Be careful, only for debug ) +let pp_tau = Fol_pretty.pp_tau + +let rec pp_pred_atom fmt p = + Fol_pretty.epp_pred_atom { + Fol_pretty.pp_type = Fol_pretty.pp_tau ; + Fol_pretty.pp_term = pp_term; + Fol_pretty.pp_pred = pp_pred_atom ; + } fmt p + +let pp_pred_vbox fmt p = + Fol_pretty.epp_pred_vbox { + Fol_pretty.pp_type = Fol_pretty.pp_tau ; + Fol_pretty.pp_term = pp_term ; + Fol_pretty.pp_pred = pp_pred_atom ; + } fmt p + +let rec pp_pred_debug fmt p = + Fol_pretty.fpp_pred pp_pred_debug pp_tau pp_term fmt p + +let pp_pred fmt p = + if Wp_parameters.debug_atleast 1 then + pp_pred_debug fmt p + else + pp_pred_vbox fmt p + +let pp_section = Fol_pretty.pp_section +let pp_term fmt t = pp_term fmt t +let pp_decl fmt d = Fol_pretty.fpp_decl pp_term pp_pred fmt d +let pp_goal fmt x g = Fol_pretty.fpp_goal pp_pred fmt x g + +let pp_var fmt x = pp_term fmt (Fol.e_var x) + +let pp_vkind fmt = function + | Formula.Model t -> pp_tau fmt t + | Formula.Acsl (_t,ty) -> !Ast_printer.d_logic_type fmt ty + +let huge_term = Fol.huge_term +let huge_pred = Fol.huge_pred + +( -------------------------------------------------------------------------- ) +( --- Creates the Data Library --- ) +( -------------------------------------------------------------------------- ) + +type interval = { + inf : integer option ; + sup : integer option ; +} + +type 'a assigned = + | Aloc of Ctypes.c_object 'a + | Arange of Ctypes.c_object * 'a * interval + +type havoc = + | Fresh of var + | Update of var * ((var * var) list -> abstract) + +let pp_interval fmt rg = + let pp_opt fmt = function + | None -> () + | Some d -> pp_term fmt d + in + Format.fprintf fmt "[%a..%a]" pp_opt rg.inf pp_opt rg.sup + +(* ------------------------------------------------------------------------ ) +( --- Calling Logic Functions and Predicates --- ) +( ------------------------------------------------------------------------ ) + +let p_app0 f = p_call f [] +let p_app1 f a = p_call f [wrap a] +let p_app2 f a b = p_call f [wrap a;wrap b] +let p_app3 f a b c = p_call f [wrap a;wrap b;wrap c] +let p_app4 f a b c d = p_call f [wrap a;wrap b;wrap c;wrap d] +let p_app5 f a b c d e = p_call f [wrap a; wrap b; wrap c; wrap d; wrap e] + +let e_app0 f = unwrap (e_call f []) +let e_app1 f a = unwrap (e_call f [wrap a]) +let e_app2 f a b = unwrap (e_call f [wrap a;wrap b]) +let e_app3 f a b c = unwrap (e_call f [wrap a;wrap b;wrap c]) +let e_app4 f a b c d = + unwrap (e_call f [wrap a;wrap b;wrap c;wrap d]) +let e_app5 f a b c d e = + unwrap (e_call f [wrap a;wrap b;wrap c;wrap d; wrap e]) + +( -------------------------------------------------------------------------- ) +( --- Dummy --- ) +( -------------------------------------------------------------------------- ) + +let gdummy = ref 0 + +let () = on_clear (fun () -> gdummy :=0) +let dummy () = incr gdummy; p_app1 "dummy" (e_int !gdummy) + +( ------------------------------------------------------------------------ ) +( --- Logic Integer Cast --- ) +( ------------------------------------------------------------------------ ) + +let modulo ti e = e_app1 (mk_imodulo ti) e +let guard ti e = p_app1 (mk_iguard ti) e +let i_convert tfrom tto e = + if Ctypes.sub_c_int tfrom tto then e else modulo tto e + +( ------------------------------------------------------------------------ ) +( --- Set Interface --- ) +( ------------------------------------------------------------------------ ) + +let empty = e_app0 mk_empty +let singleton e = e_app1 mk_singleton e + +let union a b = e_app2 mk_union a b + +let unions l = + let rec unions_aux l s = + match l with + | [] -> s + | a::m -> unions_aux m (union a s) + in + match l with + | [] -> empty + | a::m -> unions_aux m a + +let inter a b = e_app2 mk_inter a b +let remove a b = e_app2 mk_remove a b +let add_set s1 s2 = e_app2 mk_radd s1 s2 + +let mult_set s1 s2 = e_app2 mk_rmult s1 s2 +let neg_set s1 = e_app1 mk_rneg s1 + +( ------------------------------------------------------------------------ ) +( --- Integer Range Inteface --- ) +( ------------------------------------------------------------------------ ) + +let loc_range = e_app2 mk_range +let range_inf = e_app1 mk_range_inf +let range_sup = e_app1 mk_range_sup +let integers = e_app0 mk_integers + +let rec set_of_list = function + | [] -> empty + | a::m -> union (singleton a) (set_of_list m) + +let interval r = + match r.inf,r.sup with + | None,None -> integers + | Some i, None -> range_inf i + | None, Some j -> range_sup j + | Some i, Some j -> loc_range i j + +let seed = ref 0 + +let set_range_index t ri = + let rdm = e_int (incr seed ; !seed) in + e_app3 set_range_index t (interval ri) rdm + + +( ------------------------------------------------------------------------ ) +( --- Records, Unions and Arrays as First Class Values --- ) +( ------------------------------------------------------------------------ ) + +module RecName = DRegister + (struct + include Compinfo + let declare tcomp _eqname = + Formula.Trecord tcomp + let prefix = " " + let section = S_Type + let clear () = () + let pp_title _fmt _x = () + end) + +let acc_field (s:record) (f:Cil_types.fieldinfo) = + RecName.define f.Cil_types.fcomp ; e_getfield f s + +let upd_field (s:record) f v : record = + RecName.define f.Cil_types.fcomp ; e_setfield f s v + + +let acc_index = e_access +let upd_index = e_update + +( -------------------------------------------------------------------------- ) +( --- Index Functor --- ) +( -------------------------------------------------------------------------- ) + +let gindexref = ref 0 + +module type Indexed = +sig + include Registry + val get_ind : t -> integer + val has_ind : t -> pred -> bool +end + +module Dindex + (I : Identifiable) : + (Indexed with type t = I.t) = +struct + let hindex = I.H.create 131 + include DRegister + (struct + include I + let clear () = I.H.clear hindex + let section = S_Cons + let declare _ _ = + ( MUST BE INCREMENTED BEFORE: 0 is reserved for models ) + incr gindexref ; + Formula.Cons (!gindexref) + end) + let get_ind x = + let k = I.index x in + try I.H.find hindex k + with Not_found -> + let d = get_definition x in + let t : integer = unwrap (e_call d.d_name []) in + I.H.add hindex k t ; t + + let has_ind x p = + try + let d = get_definition x in + Fol.pred_calls d.d_name p + with Not_found -> false + +end + +( -------------------------------------------------------------------------- ) +( --- Built-in Names --- ) +( -------------------------------------------------------------------------- ) + +module Findex = Dindex(Fieldinfo) +module Xindex = Dindex(Varinfo) +module Tindex = Dindex(Compinfo) +module Aindex = Dindex(Varaddr) +module LTindex = Dindex(LTypeinfo) + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_formula.mli frama-c-20111001+nitrogen+dfsg/src/wp/fol_formula.mli --- frama-c-20110201+carbon+dfsg/src/wp/fol_formula.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_formula.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,30 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( ) +() + +open Formula +open Ctypes + + +include Formula.S with type 'a term = Fol.term + and type pred = Fol.pred + and type var = Fol.Var.t + and type decl = Fol.decl diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_let.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_let.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_let.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_let.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,130 @@ +() +( ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Fol + +(* -------------------------------------------------------------------------- ) +( --- Alpha Conversion --- ) +( -------------------------------------------------------------------------- ) + +( alpha-conversion *) + +module Smap = Datatype.String.Map + +type sigma = { + cpt : int Smap.t ; + var : term Vmap.t ; +} + +let fresh sigma x = + let base = Var.basename x in + let tau = Var.var_type x in + let k = try Smap.find base sigma.cpt with Not_found -> 0 in + let y = Var.ident_named_var base k tau in + y , { cpt = Smap.add base (succ k) sigma.cpt ; + var = Vmap.add x (e_var y) sigma.var } + +let alpha sigma x = + try Vmap.find x sigma.var + with Not_found -> Wp_parameters.fatal "Unbound fol-variable %s (let)" (Var.var_name x) + +let rec def = function Pnamed(_,p) -> def p | p -> p +let rec redef p p' = match p with Pnamed(a,p0) -> Pnamed(a,redef p0 p') | _ -> p' +let rec is_simple = function (Tvar _ | Tconst _ | Tapp(_,[])) -> true | _ -> false +let bind x v sigma = { sigma with var = Vmap.add x v sigma.var } + +let rec term sigma = function + | Tconst _ as c -> c + | Tvar v -> alpha sigma v + | Tgetfield(f,r) -> e_getfield f (term sigma r) + | Tsetfield(f,r,v) -> e_setfield f (term sigma r) (term sigma v) + | Taccess(t,i) -> e_access (term sigma t) (term sigma i) + | Tupdate(t,i,v) -> e_update (term sigma t) (term sigma i) (term sigma v) + | Tapp (n,tl) -> e_app n (List.map (term sigma) tl) + | Tif (t1,t2,t3) -> e_if (term sigma t1) (term sigma t2) (term sigma t3) + | Tlet (x,v,t) -> + let v = term sigma v in + if is_simple v && Wp_parameters.Simpl.get() + then + term (bind x v sigma) t + else + let x,sigma = fresh sigma x in + e_let x v (term sigma t) + +let rec pred sigma = function + | Papp(f,ts) -> p_app f (List.map (term sigma) ts) + | Ptrue -> Ptrue + | Pfalse -> Pfalse + | Pif(e,p,q) -> p_if (term sigma e) (pred sigma p) (pred sigma q) + | Pand(p,q) -> p_and (pred sigma p) (pred sigma q) + | Por(p,q) -> p_or (pred sigma p) (pred sigma q) + | Piff(p,q) -> p_iff (pred sigma p) (pred sigma q) + | Pnot p -> p_not (pred sigma p) + | Pnamed(a,p) -> p_named a (pred sigma p) + | Pforall(x,p) -> let x,sigma = fresh sigma x in p_forall x (pred sigma p) + | Pexists(x,p) -> let x,sigma = fresh sigma x in p_exists x (pred sigma p) + | Plet(x,v,p) -> + let v = term sigma v in + if is_simple v && Wp_parameters.Simpl.get() + then + pred (bind x v sigma) p + else + let x,sigma = fresh sigma x in + p_let x v (pred sigma p) + | Pimplies(p,q) -> + match def p with + | Papp(("eq"|"eq_int"|"eq_real"),([Tvar x;e] | [e;Tvar x])) when Wp_parameters.Simpl.get() -> + let ve = term sigma e in + if is_simple ve then + let vx = alpha sigma x in + let q = pred (bind x ve sigma) q in + let p = redef p (Papp("eq",[vx;ve])) in + p_implies p q + else + let vx = alpha sigma x in + let q = pred sigma q in + let p = redef p (Papp("eq",[vx;ve])) in + p_implies p q + | _ -> + let p = pred sigma p in + let q = pred sigma q in + match def p with + | Papp("eq",([Tvar x;v] | [v;Tvar x])) + when is_simple v && Wp_parameters.Simpl.get() -> + let q = Fol.pred_replace (fun _ -> None) x v q in + p_implies p q + | _ -> p_implies p q + +let empty = { cpt = Smap.empty ; var = Vmap.empty } + +let compile = pred empty + +let rec fresh_params ys sigma = function + | [] -> List.rev ys , sigma + | x::xs -> + let y,sigma = fresh sigma x in + fresh_params (y::ys) sigma xs + +let compile_def xs p = + let ys,sigma = fresh_params [] empty xs in + ys , pred sigma p + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_let.mli frama-c-20111001+nitrogen+dfsg/src/wp/fol_let.mli --- frama-c-20110201+carbon+dfsg/src/wp/fol_let.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_let.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,28 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- FOL Alpha-Normalization --- ) +( -------------------------------------------------------------------------- ) + +val compile : Fol.pred -> Fol.pred +val compile_def : Fol.Var.t list -> Fol.pred -> Fol.Var.t list Fol.pred diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,937 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_datatype + +(* ------------------------------------------------------------------------ *) +(** {2 Constants} ) + +type constant = + | ConstInt of string + | ConstBool of bool + | ConstUnit + | ConstFloat of string + +let c_bool b = ConstBool b +let c_int_of_str s = ConstInt s +let c_int i = ConstInt (string_of_int i) +let c_float_of_str s = ConstFloat s +let c_float f = ConstFloat (string_of_float f) + +( ------------------------------------------------------------------------ *) +(** {2 Variables} ) + +module Var = struct + + type t = + (string int option * Formula.tau * Cil_types.logic_type option) + + let var_type (_, _, t,_)= t + + let var_name (v,p,_,_)= + match p with + | None -> v + | Some id -> Printf.sprintf "%s_%d" v id + + let basename (x,_,_,_) = x + + let kind_of_var (_,_,t,p)= + match p with + | Some ty -> Formula.Acsl(t,ty) + | None -> Formula.Model t + + let var_counter = ref 0 + + (* ensures that the counter is still ok even if some numbers are used + * by external function through [mk] or [ident_named_var] ) + let check_cpt k = if k > !var_counter then var_counter := k + + let fresh_named_var name t = + incr var_counter; + (name, Some !var_counter, t,None) + + let fresh_var (name, _, t,_) = fresh_named_var name t + + let mk x k_opt tau ltype_opt = + (match k_opt with None -> () | Some k -> check_cpt k); + (x, k_opt, tau, ltype_opt) + + let ident_named_var name k t = + check_cpt k; (name,Some k,t,None) + + let equal v1 v2 = match v1, v2 with + | (x,c,_,_) , (y,d,_,_) -> c=d && x=y + + let compare v1 v2 = match v1, v2 with + | (v1, id1, _,_), (v2, id2, _,_) -> + let cmp = String.compare v1 v2 in + if cmp <> 0 then cmp + else + begin + match id1 , id2 with + | None , None -> 0 + | Some _ , None -> 1 + | None , Some _ -> (-1) + | Some id1 , Some id2 -> Pervasives.compare id1 id2 + end + +end + +module Vset = Set.Make(Var) +module Vmap = Map.Make(Var) + +( ------------------------------------------------------------------------ *) +(** {2 Terms} ) +( ------------------------------------------------------------------------ ) + +type term = + | Tconst of constant + | Tvar of Var.t + | Tapp of string term list + | Tgetfield of Cil_types.fieldinfo * term + | Tsetfield of Cil_types.fieldinfo * term * term + | Taccess of term * term + | Tupdate of term * term * term + | Tif of term * term * term + | Tlet of Var.t * term * term + +(* -----------------------------------*) +(** {3 Term comparison} ) + +let rec eq_terms e1 e2 = + match e1, e2 with + | Tconst c1, Tconst c2 -> Pervasives.compare c1 c2 = 0 + | Tvar v1, Tvar v2 -> Var.equal v1 v2 + | Tapp (f1, args1), Tapp (f2, args2) -> + f1 = f2 && List.for_all2 eq_terms args1 args2 + | Tif (c1, t1, e1), Tif (c2, t2, e2) -> + eq_terms c1 c2 && eq_terms t1 t2 && eq_terms e1 e2 + | Tlet (x,v,t),Tlet(x',v',t') -> + Var.equal x x' && eq_terms v v' && eq_terms t t' + | Tgetfield (f,r) , Tgetfield(g,s) -> + Fieldinfo.equal f g && eq_terms r s + | Tsetfield (f,r,v) , Tsetfield(g,s,w) -> + Fieldinfo.equal f g && eq_terms r s && eq_terms v w + | Taccess (t,i) , Taccess (u,j) -> + eq_terms t u && eq_terms i j + | Tupdate (t,i,v), Tupdate(u,j,w) -> + eq_terms t u && eq_terms i j && eq_terms v w + | _ -> false + +( -----------------------------------*) +(** {3 Term visitors} ) + +let rec e_has_var xs e = + let frec = e_has_var xs in + match e with + | Tconst _ -> false + | Tvar y -> List.exists (Var.equal y) xs + | Tapp(_,ts) -> List.exists (frec) ts + | Tgetfield(_,r) -> frec r + | Tsetfield(_,r,v) -> frec r || frec v + | Taccess(t,i) -> frec t || frec i + | Tupdate (t,i,v) -> frec t || frec i || frec v + | Tif(a,b,c) -> frec a || frec b || frec c + | Tlet(x,v,t) -> + frec v || + (let xs = List.filter (fun y -> not (Var.equal x y)) xs in + xs <> [] && e_has_var xs t) + +let rec e_closed xs = function + | Tconst _ -> true + | Tvar y -> List.exists (Var.equal y) xs + | Tgetfield(_,r) -> e_closed xs r + | Tsetfield(_,r,v) -> e_closed xs r && e_closed xs v + | Taccess(t,i) -> e_closed xs t && e_closed xs i + | Tupdate(t,i,v) -> e_closed xs t && e_closed xs i && e_closed xs v + | Tapp(_,ts) -> List.for_all (e_closed xs) ts + | Tif(a,b,c) -> e_closed xs a && e_closed xs b && e_closed xs c + | Tlet(x,v,t) -> e_closed xs v && e_closed (x::xs) t + +( -----------------------------------*) +(** {3 Term smart constructors} ) + +let e_true = Tconst (c_bool true) +let e_false = Tconst (c_bool false) +let e_int i = Tconst (c_int i) +let e_int64 i = Tconst (ConstInt (Int64.to_string i)) +let e_float f = Tconst (c_float f) +let e_cnst c = Tconst c +let e_var v = Tvar v + +let e_if c t f = match c with + | Tconst (ConstBool true) -> t + | Tconst (ConstBool false) -> f + | _ -> if eq_terms t f then t else Tif (c, t, f) + +let i_compute zop a b = + let z_a = Big_int.big_int_of_string a in + let z_b = Big_int.big_int_of_string b in + Tconst(ConstInt(Big_int.string_of_big_int (zop z_a z_b))) + +let i_apply zop a = + let z_a = Big_int.big_int_of_string a in + Tconst(ConstInt(Big_int.string_of_big_int (zop z_a))) + +let simpl() = Wp_parameters.Simpl.get() + + +let signed_in_bound b z opt_z def_z = + let bz = Big_int.big_int_of_string z in + if (Big_int.le_big_int (Big_int.minus_big_int b) bz && Big_int.lt_big_int bz b) + then opt_z else def_z + +let unsigned_in_bound b z opt_z def_z = + let bz = Big_int.big_int_of_string z in + if (Big_int.le_big_int Big_int.zero_big_int bz && Big_int.lt_big_int bz b) + then opt_z else def_z + +let as_int_format fmt z = + let def = Tapp ("as_int",[Tapp(fmt,[]) ; Tconst(ConstInt z)]) in + let opt = Tconst (ConstInt z) in + let signed_in_bound b = signed_in_bound b z opt def in + let unsigned_in_bound b =unsigned_in_bound b z opt def in + match fmt with + | "uint8_format" -> + let b = Big_int.big_int_of_int 256 in unsigned_in_bound b + | "sint8_format" -> + let b = Big_int.big_int_of_int 128 in signed_in_bound b + | "uint16_format" -> + let b = Big_int.big_int_of_int 65536 in unsigned_in_bound b + | "sint16_format" -> + let b = Big_int.big_int_of_int 32768 in signed_in_bound b + | "uint32_format" -> + let b = Big_int.big_int_of_string ("4294967296") in + unsigned_in_bound b + | "sint32_format" -> + let b = Big_int.big_int_of_string ("2147483648") in + signed_in_bound b + | "uint64_format" -> + let b = Big_int.big_int_of_string ("18446744073709551616") in + unsigned_in_bound b + | "sint64_format" -> + let b = Big_int.big_int_of_string ("9223372036854775808") in + signed_in_bound b + |_ -> def + + +let as_int s z = + let def = Tapp (s,[Tconst(ConstInt z)]) in + let opt = Tconst (ConstInt z) in + let signed_in_bound b = signed_in_bound b z opt def in + let unsigned_in_bound b = unsigned_in_bound b z opt def in + match s with + | "as_uint8" -> + let b = Big_int.big_int_of_int 256 in unsigned_in_bound b + | "as_sint8" -> + let b = Big_int.big_int_of_int 128 in signed_in_bound b + | "as_uint16" -> + let b = Big_int.big_int_of_int 65536 in unsigned_in_bound b + | "as_sint16" -> + let b = Big_int.big_int_of_int 32768 in signed_in_bound b + | "as_uint32" -> + let b = Big_int.big_int_of_string ("4294967296") in + unsigned_in_bound b + | "as_sint32" -> + let b = Big_int.big_int_of_string ("2147483648") in + signed_in_bound b + | "as_uint64" -> + let b = Big_int.big_int_of_string ("18446744073709551616") in + unsigned_in_bound b + | "as_sint64" -> + let b = Big_int.big_int_of_string ("9223372036854775808") in + signed_in_bound b + |_ -> def + + + +let coercion f g d = + let def = Tapp (f , [Tapp(g,[d])]) in + match f,g,d with + | "data_of_addr", "addr_of_data",_ + | "data_of_uint8", "uint8_of_data",_ + | "data_of_sint8", "sint8_of_data",_ + | "data_of_uint16", "uint16_of_data",_ + | "data_of_sint16", "sint16_of_data",_ + | "data_of_uint32", "uint32_of_data",_ + | "data_of_sint32", "sint32_of_data",_ + | "data_of_uint64", "uint64_of_data",_ + | "data_of_sint64", "sint64_of_data",_ + | "data_of_float16", "float16_of_data",_ + | "data_of_float32", "float32_of_data",_ + | "data_of_float64", "float64_of_data",_ + | "data_of_float128", "float128_of_data",_ -> d + | "uint8_of_data", "data_of_uint8",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_int 256 in unsigned_in_bound b z d def + | "sint8_of_data", "data_of_sint8",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_int 128 in signed_in_bound b z d def + | "uint16_of_data", "data_of_uint16",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_int 65536 in unsigned_in_bound b z d def + | "sint16_of_data", "data_of_sint16",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_int 32768 in signed_in_bound b z d def + | "uint32_of_data", "data_of_uint32",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_string ("4294967296") in unsigned_in_bound b z d def + | "sint32_of_data", "data_of_sint32",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_string ("2147483648") in signed_in_bound b z d def + | "uint64_of_data", "data_of_uint64",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_string ("18446744073709551616") in unsigned_in_bound b z d def + | "sint64_of_data", "data_of_sint64",Tconst(ConstInt z) -> + let b = Big_int.big_int_of_string ("9223372036854775808") in signed_in_bound b z d def + | _ -> def + + +let e_app f args = + if not (simpl()) then Tapp(f,args) + else + match f , args with + | "neg_int" , [ Tapp( "neg_int" , [a] ) ] -> a + | "neg_real" , [ Tapp( "neg_real" , [a] ) ] -> a + | "neg_int" , [ Tconst (ConstInt a) ] -> + i_apply Big_int.minus_big_int a + | "add_int" , [ Tconst (ConstInt a) ; Tconst (ConstInt b) ] -> + i_compute Big_int.add_big_int a b + | "sub_int" , [ Tconst (ConstInt a) ; Tconst (ConstInt b) ] -> + i_compute Big_int.sub_big_int a b + | "mul_int" , [ Tconst (ConstInt a) ; Tconst (ConstInt b) ] -> + i_compute Big_int.mult_big_int a b + | "add_int" , [ Tconst (ConstInt "0") ; x ] -> x + | "add_int" , [ x ; Tconst (ConstInt "0") ] -> x + | "sub_int" , [ x ; Tconst (ConstInt "0") ] -> x + | "mul_int" , [ Tconst (ConstInt "1") ; x ] -> x + | "mul_int" , [ x ; Tconst (ConstInt "1") ] -> x + | "mul_int" , [ (Tconst (ConstInt "0")) as z ; _ ] -> z + | "mul_int" , [ _ ; (Tconst (ConstInt "0")) as z ] -> z + | "add_int" , [ b ; Tapp("sub_int",[a;c]) ] when eq_terms b c -> a ; + | "add_int" , [ Tapp("sub_int",[a;b]) ; c ] when eq_terms b c -> a + | "sub_int" , [ Tapp("add_int",[a;b]) ; c ] when eq_terms b c -> a + | "encode" , [ Tapp("decode" , [ a ; fmt ]) ; fmt' ] when eq_terms fmt fmt' -> a + | "decode" , [ Tapp("encode" , [ a ; fmt ]) ; fmt' ] when eq_terms fmt fmt' -> a + | "as_int" , [Tapp(fmt,[]) ; Tconst(ConstInt z)] -> as_int_format fmt z + | f , [Tconst(ConstInt z)] -> as_int f z + | f , [Tapp(g,[d])] -> coercion f g d + | _ -> Tapp (f, args) + +let e_let x exp t = if e_has_var [x] t then Tlet (x, exp, t) else t + +let case_of = function + | Tconst(ConstInt s) -> Some s + | _ -> None + +let e_update t i v = Tupdate(t,i,v) +let e_access t i = + match t with + | Tupdate(_,j,v) when simpl() && eq_terms i j -> v + | t -> Taccess(t,i) + +let e_setfield f r v = Tsetfield(f,r,v) +let e_getfield f r = + match r with + | Tsetfield(g,s,w) when simpl() -> + if Fieldinfo.equal f g + then w ( get set same field ) + else + if f.Cil_types.fcomp.Cil_types.cstruct then + Tgetfield(f,s) ( get set other of record only ) + else + Tgetfield(f,r) + | r -> Tgetfield(f,r) + + +( -----------------------------------*) +(** {3 Term transformation} *) + +(** Apply [do_var] in term subexpressions.) +let rec change_in_exp do_var exp = + let frec = change_in_exp do_var in + match exp with + | Tconst c -> e_cnst c + | Tvar v -> (match do_var v with Some e -> e | None -> e_var v) + | Tgetfield(f,r) -> e_getfield f (frec r) + | Tsetfield(f,r,v) -> e_setfield f (frec r) (frec v) + | Taccess(t,i) -> e_access (frec t) (frec i) + | Tupdate(t,i,v) -> e_update (frec t) (frec i) (frec v) + | Tapp (n,tl) -> e_app n (List.map (frec) tl) + | Tif (t1,t2,t3) -> e_if (frec t1) (frec t2) (frec t3) + | Tlet (x,v,t) -> e_let x (frec v) (frec t) + +let rec term_replace alpha x exp t = + let frec = term_replace alpha x exp in + match t with + | Tconst _ -> t + | Tvar x0 -> if Var.equal x0 x then exp else t + | Tapp (f, ts) -> e_app f (List.map (frec) ts) + | Tif (a, b, c) -> e_if (frec a) (frec b) (frec c) + | Tgetfield(f,r) -> e_getfield f (frec r) + | Tsetfield(f,r,v) -> e_setfield f (frec r) (frec v) + | Taccess(t,i) -> e_access (frec t) (frec i) + | Tupdate(t,i,v) -> e_update (frec t) (frec i) (frec v) + | Tlet (x0, a, b) -> + if e_has_var [x0] exp then + match alpha x with + | None -> Tlet(x,exp,t) + | Some y -> + let by = term_replace alpha x0 (Tvar y) b in + Tlet(y,frec a,frec by) + else + let b' = if Var.equal x0 x then b else frec b in + Tlet(x0,frec a,b') + +let alpha_bound_var alpha v = + let old = try Some (Vmap.find v alpha) with Not_found -> None in + old, Vmap.add v v alpha + +let alpha_unbound alpha v old = match old with + | Some v' -> Vmap.add v v' alpha + | None -> Vmap.remove v alpha + +let apply_alpha alpha v = + try alpha, Vmap.find v alpha + with Not_found -> + let v' = Var.fresh_var v in + let alpha = Vmap.add v v' alpha in + alpha, v' + +let rec term_alpha_cv alpha t = + let do_term alpha t = term_alpha_cv alpha t in + let rec do_terms alpha l = terms_alpha_cv alpha l in + match t with + | Tconst _ -> alpha, t + | Tvar v -> + let alpha, v = apply_alpha alpha v in alpha, Tvar v + | Tapp (f, ts) -> + let alpha, ts = do_terms alpha ts in + alpha, e_app f ts + | Tgetfield(f,r) -> + let alpha, r = do_term alpha r in + alpha,e_getfield f r + |Tsetfield(f,r,v) -> + let alpha,r = do_term alpha r in + let alpha,v = do_term alpha v in + alpha, e_setfield f r v + | Taccess(t,i) -> + let alpha,t = do_term alpha t in + let alpha,i = do_term alpha i in + alpha,e_access t i + | Tupdate(t,i,v) -> + let alpha,t = do_term alpha t in + let alpha,i = do_term alpha i in + let alpha,v = do_term alpha v in + alpha, e_update t i v + | Tif (a, b, c) -> + let alpha, a = do_term alpha a in + let alpha, b = do_term alpha b in + let alpha, c = do_term alpha c in + alpha, e_if a b c + | Tlet (x, a, b) -> + let alpha, a = do_term alpha a in ( a doesn't see x ) + let old_x, alpha = alpha_bound_var alpha x in + let alpha, b = do_term alpha b in + let alpha = alpha_unbound alpha x old_x in ( restore old_x ) + alpha, e_let x a b +and terms_alpha_cv alpha l = match l with [] -> alpha, [] + | t::l -> + let alpha, t = term_alpha_cv alpha t in + let alpha, l = terms_alpha_cv alpha l in + alpha, t::l + +( ------------------------------------------------------------------------ *) +(** {2 Predicates} ) +( ------------------------------------------------------------------------ ) + +type pred = + | Papp of string term list + | Ptrue + | Pfalse + | Pimplies of pred * pred + | Pif of term * pred * pred + | Pand of pred * pred + | Por of pred * pred + | Piff of pred * pred + | Pnot of pred + | Pforall of Var.t * pred + | Pexists of Var.t * pred + | Plet of Var.t * term * pred + | Pnamed of string * pred + +let rec eq_preds p q = + match p,q with + | Papp(f,xs) , Papp(g,ys) -> + f = g && List.for_all2 eq_terms xs ys + | Ptrue , Ptrue -> true + | Pfalse , Pfalse -> true + | Pnamed(_,p) , q -> eq_preds p q + | p , Pnamed(_,q) -> eq_preds p q + | Pnot p , Pnot q -> eq_preds p q + | _ -> false + +let rec p_has_var xs = function + | Papp(_,ts) -> List.exists (e_has_var xs) ts + | Ptrue | Pfalse -> false + | Pimplies(p,q) | Pand(p,q) | Por(p,q) | Piff(p,q) -> + p_has_var xs p || p_has_var xs q + | Pif(t,p,q) -> + e_has_var xs t || p_has_var xs p || p_has_var xs q + | Pnot p | Pnamed(_,p) -> p_has_var xs p + | Pforall(x,p) | Pexists(x,p) -> + let xs = List.filter (fun y -> not (Var.equal x y)) xs in + xs <> [] && p_has_var xs p + | Plet(x,a,p) -> + e_has_var xs a || + (let xs = List.filter (fun y -> not (Var.equal x y)) xs in + xs <> [] && p_has_var xs p) + +let rec p_closed xs = function + | Papp(_,ts) -> List.for_all (e_closed xs) ts + | Ptrue | Pfalse -> true + | Pimplies(p,q) | Pand(p,q) | Por(p,q) | Piff(p,q) -> + p_closed xs p && p_closed xs q + | Pif(t,p,q) -> + e_closed xs t && p_closed xs p && p_closed xs q + | Pnot p | Pnamed(_,p) -> p_closed xs p + | Pforall(x,p) | Pexists(x,p) -> p_closed (x::xs) p + | Plet(x,a,p) -> + e_closed xs a && p_closed (x::xs) p + +(* -----------------------------------*) +(** {3 Predicates smart constructors} ) + +let pp_term : (Format.formatter -> term -> unit) ref = ref (fun _ _ -> ()) + +let i_compare zop a b = + if zop (Big_int.big_int_of_string a) (Big_int.big_int_of_string b) + then Ptrue else Pfalse + +let p_app name args = + if not (simpl()) then Papp(name,args) + else + match name , args with + | "eq", [ a ; b ] when eq_terms a b -> Ptrue + | "neq", [ a ; b ] when eq_terms a b -> Pfalse + | "le_int" , [a;b] when eq_terms a b -> Ptrue + | "lt_int" , [a;b] when eq_terms a b -> Pfalse + | "eq" , [ Tconst(ConstInt a) ; Tconst(ConstInt b) ] -> + i_compare Big_int.eq_big_int a b + | "neq" , [ Tconst(ConstInt a) ; Tconst(ConstInt b) ] -> + i_compare (fun za zb -> not (Big_int.eq_big_int za zb)) a b + | "le_int" , [ Tconst(ConstInt a) ; Tconst(ConstInt b) ] -> + i_compare Big_int.le_big_int a b + | "lt_int" , [ Tconst(ConstInt a) ; Tconst(ConstInt b) ] -> + i_compare Big_int.lt_big_int a b + | _ -> Papp (name,args) + +let rec val_of = function Pnamed (_,p) -> val_of p | p -> p +let rec cut p = function Pnamed (a,q) -> Pnamed(a,cut p q) | _ -> p + +let rec is_true = function + | Ptrue -> true + | Pnamed(_,p) -> is_true p + | _ -> false + +let rec is_false = function + | Pfalse -> true + | Pnamed(_,p) -> is_false p + | _ -> false + +let p_not p = match val_of p with + | Ptrue -> cut Pfalse p + | Pfalse -> cut Ptrue p + | Papp( "eq" , w ) -> p_app "neq" w + | Papp( "neq" , w ) -> p_app "eq" w + | Papp( "le_int" , [a;b] ) -> p_app "lt_int" [b;a] + | Papp( "lt_int" , [a;b] ) -> p_app "le_int" [b;a] + | _ -> Pnot p + +let p_and p1 p2 = match val_of p1, val_of p2 with + | Ptrue, _ -> p2 + | _, Ptrue -> p1 + | Pfalse,_-> cut Pfalse p1 + | _,Pfalse -> cut Pfalse p2 + | _ -> Pand (p1, p2) + +let p_or p1 p2 = match val_of p1, val_of p2 with + | Ptrue, _ -> cut Ptrue p1 + | _ , Ptrue -> cut Ptrue p2 + | Pfalse ,_ -> p2 + | _ ,Pfalse -> p1 + | _ -> Por (p1,p2) + +let p_xor p1 p2 = match val_of p1, val_of p2 with + | Ptrue , Ptrue -> cut (cut Pfalse p2) p1 + | Ptrue ,_ -> cut Ptrue p1 + | _,Ptrue -> cut Ptrue p2 + | Pfalse , _ -> p2 + | _ , Pfalse -> p1 + | _ -> Pnot(Piff(p1,p2)) + +let p_implies p1 p2 = + match val_of p1, val_of p2 with + | Ptrue, _ -> p2 + | Pfalse, _ -> cut Ptrue p1 + | _, Ptrue -> cut Ptrue p2 + | _ -> Pimplies (p1, p2) + +let rec p_conj = function + | [] -> Ptrue + | [p] -> p + | p::ps -> p_and p (p_conj ps) + +let rec p_disj = function + | [] -> Pfalse + | [p] -> p + | p::ps -> p_or p (p_disj ps) + +let p_if c p1 p2 = match c, val_of p1, val_of p2 with + | (_,Ptrue, Ptrue ) -> cut (cut Ptrue p2) p1 + | (_,Pfalse, Pfalse ) -> cut (cut Pfalse p2) p1 + | (t,_ , _) -> Pif (t,p1,p2) + +let p_iff p1 p2 = + match val_of p1,val_of p2 with + | Ptrue ,_ -> p2 + | _ ,Ptrue -> p1 + | Pfalse, _ -> p_not p2 + | _ , Pfalse -> p_not p1 + | _ -> Piff (p1,p2) + +let p_eq e1 e2 = + if eq_terms e1 e2 then Ptrue else p_app "eq" [e1; e2] +let p_neq e1 e2 = + if eq_terms e1 e2 then Pfalse else p_app "neq" [e1; e2] + +let p_forall x p = + match val_of p with + | Ptrue | Pfalse | Papp ("dummy",_) -> p + | _ -> if p_has_var [x] p then Pforall(x,p) else p + +let p_exists x p = + match val_of p with + | Ptrue | Pfalse | Papp ("dummy",_) -> p + | _ -> if p_has_var [x] p then Pexists(x,p) else p + +let p_let x v p = + match val_of p with + | Ptrue | Pfalse| Papp ("dummy",_) -> p + | _ -> if p_has_var [x] p then Plet(x,v,p) else p + +let p_named name p = Pnamed(name,p) + +( ------------------------------------------------------------------------ ) +( --- Propagation of transformations --- ) +( ------------------------------------------------------------------------ *) + + +(** apply [do_exp] on each sub expression of the predicate. +* [quantif_do_exp] is called to change [do_exp] if needed +* when we go under a quantification. +* This version makes possible to have a different flavor of term, +* ie. it can be used for translation. +* TODOopt: we could have another optimized version if the types of terms +* are the same in order to avoid building new terms when there is no +* modification. +* ) +let rec change_exp_in_pred (do_exp:term -> term) + (quantif_do_exp: (term -> term) -> Var.t -> + (term -> term)) p = + let subst_pred = change_exp_in_pred do_exp quantif_do_exp in + match p with + | Ptrue -> Ptrue + | Pfalse -> Pfalse + | Pif (t,p1,p2) -> + Pif (do_exp t, subst_pred p1, subst_pred p2) + | Pnot p -> p_not (subst_pred p) + | Pforall (v,p') -> + let f = quantif_do_exp do_exp v in + Pforall (v,change_exp_in_pred f quantif_do_exp p') + | Pexists (v,p') -> + let f = quantif_do_exp do_exp v in + Pexists (v,change_exp_in_pred f quantif_do_exp p') + | Plet (x,v,p) -> + let f = quantif_do_exp do_exp x in + Plet (x, do_exp v,change_exp_in_pred f quantif_do_exp p) + | Pnamed (n,p) -> Pnamed (n,subst_pred p) + | Pimplies (p1,p2) -> p_implies (subst_pred p1) (subst_pred p2) + | Pand (p1,p2) -> p_and (subst_pred p1) (subst_pred p2) + | Por (p1,p2) -> p_or (subst_pred p1) (subst_pred p2) + | Piff (p1,p2) -> p_iff (subst_pred p1) (subst_pred p2) + | Papp (n,t) -> p_app n (List.map do_exp t) + +let no_quantif_do_exp do_exp qqvar = + let var_term = e_var qqvar in + match do_exp var_term with + | Tvar v when Var.equal qqvar v -> do_exp + | _ -> assert false +( +let change_data_in_pred do_data_rec p = + change_exp_in_pred (change_data_in_exp do_data_rec) no_quantif_do_exp p +) +( ------------------------------------------------------------------------ ) +( --- Alpha-conversion --- ) +( ------------------------------------------------------------------------ ) + +let rec pred_alpha_cv alpha p = + let do_pred alpha p = pred_alpha_cv alpha p in + let rec do_preds alpha l = match l with [] -> alpha, l + | p::l -> + let alpha, p = do_pred alpha p in + let alpha, l = do_preds alpha l in + alpha, p::l + in + match p with + | Ptrue | Pfalse -> alpha, p + | Pif (t,p1,p2) -> + let alpha, t = term_alpha_cv alpha t in + let alpha, p1 = do_pred alpha p1 in + let alpha, p2 = do_pred alpha p2 in + alpha, Pif (t,p1,p2) + | Pnot p -> let alpha, p = do_pred alpha p in alpha, Pnot p + | Pforall (x,p) -> + let old_x, alpha = alpha_bound_var alpha x in + let alpha, p = do_pred alpha p in + let alpha = alpha_unbound alpha x old_x in + alpha, Pforall (x,p) + | Pexists (x,p) -> + let old_x, alpha = alpha_bound_var alpha x in + let alpha, p = do_pred alpha p in + let alpha = alpha_unbound alpha x old_x in + alpha, Pexists (x,p) + | Plet (x,t,p) -> + let alpha, t = term_alpha_cv alpha t in + let old_x, alpha = alpha_bound_var alpha x in + let alpha, p = do_pred alpha p in + let alpha = alpha_unbound alpha x old_x in + alpha, Plet (x,t,p) + | Pnamed (n,p) -> let alpha, p = do_pred alpha p in alpha, Pnamed (n,p) + | Pimplies (p1,p2) -> + let alpha, p1 = do_pred alpha p1 in + let alpha, p2 = do_pred alpha p2 in + alpha, Pimplies (p1,p2) + | Pand (p1,p2) -> + let alpha, p1 = do_pred alpha p1 in + let alpha, p2 = do_pred alpha p2 in + alpha, Pand (p1,p2) + | Por (p1,p2) -> + let alpha, p1 = do_pred alpha p1 in + let alpha, p2 = do_pred alpha p2 in + alpha, Por (p1,p2) + | Piff (p1,p2) -> + let alpha, p1 = do_pred alpha p1 in + let alpha, p2 = do_pred alpha p2 in + alpha, Piff (p1,p2) + | Papp (n,lt) -> + let alpha, lt = terms_alpha_cv alpha lt in alpha, p_app n lt + + +let p_alpha_cv p = + let alpha, p = pred_alpha_cv Vmap.empty p in + let vars = Vmap.fold (fun _v v' acc -> v'::acc) alpha [] in + vars, p + +( ------------------------------------------------------------------------ ) +( --- Translation (data type can be modified) --- ) +( ------------------------------------------------------------------------ ) + +let change_exp_in_pred do_exp = change_exp_in_pred do_exp no_quantif_do_exp + +( ------------------------------------------------------------------------ ) +( --- Variable substitutions ) +( ------------------------------------------------------------------------ *) + +(** Similar to [change_vars_in_exp] but on predicates. +* Notice that we assume (and check) that [var_subst] only works on free +* variables (and that they are different from bounded ones). +*) +let subst_vars_in_pred var_subst p = + let rec do_exp exp = change_in_exp var_subst exp + in change_exp_in_pred do_exp p + +(** Specialized version of [subst_vars_in_pred] to substitute one variable [v] +* by and expression [exp] in a predicate [p]. ) +let subst_in_pred x exp p = + let var_subst v = if Var.equal v x then Some exp else None in + subst_vars_in_pred var_subst p + + ( +let nb_var_in_pred prop_in_data v p = + let nb_occ = ref 0 in + let do_var () var = if Var.equal v var then nb_occ := !nb_occ + 1 in + let rec do_exp () e = fold_data_in_exp do_var do_data () e + and do_data () d = ignore (prop_in_data (fun e -> do_exp () e; e) d) in + let _ = fold_exp_in_pred do_exp () p in + !nb_occ +*) + +(** Build a predicate equivalent to [let v = e in p] but may use the +* substitution in some simple cases (like substitute a variable by another +* variable for instance). +* [fresh] is only meaningfull when the [let] is actually built: it tells if we +* have to build a new variable for [v]. +) +let let_pred ~fresh v e p = + if p = Ptrue then Ptrue + else begin + match e with + | Tconst _ | Tvar _ -> subst_in_pred v e p + | _ -> + ( let nb_occ = nb_var_in_pred prop_in_data v p in + (* TODOopt : do only one visit ) + if nb_occ = 0 then p + ( else if nb_occ = 1 then subst_in_pred prop_in_data v e p ) + else ) + if fresh then + let v' = Var.fresh_var v in + let p = subst_in_pred v (e_var v') p in + p_let v' e p + else p_let v e p + end + +let rec pred_replace alpha x exp p = + let frec = pred_replace alpha x exp in + match p with + | Papp(f,ts) -> p_app f (List.map (term_replace alpha x exp) ts) + | (Ptrue | Pfalse) as p -> p + | Pimplies(p,q) -> p_implies (frec p) (frec q) + | Pif(a,p,q) -> p_if (term_replace alpha x exp a) (frec p) (frec q) + | Pand(p,q) -> p_and (frec p) (frec q) + | Por(p,q) -> p_or (frec p) (frec q) + | Piff(p,q) -> p_iff (frec p) (frec q) + | Pnot(p) -> p_not (frec p) + | Pforall(x0,p) as p0 -> + begin + if Var.equal x x0 then p0 + else if e_has_var [x0] exp then + match alpha x with + | None -> Plet(x,exp,p0) + | Some y -> + let py = pred_replace alpha x0 (Tvar y) p in + let py' = frec py in + Pforall( y , py' ) + else Pforall(x0, frec p) + end + | Pexists(x0,p) as p0 -> + begin + if Var.equal x x0 then p0 + else if e_has_var [x0] exp then + match alpha x with + | None -> Plet(x,exp,p0) + | Some y -> + let py = pred_replace alpha x0 (Tvar y) p in + let py' = frec py in + Pexists( y , py' ) + else Pexists(x0,frec p) + end + | Plet(x0,t,p) as p0 -> + begin + if e_has_var [x0] exp then + match alpha x with + | None -> Plet(x,exp,p0) + | Some y -> + let t' = term_replace alpha x exp t in + let py = pred_replace alpha x0 (Tvar y) p in + let py' = frec py in + Plet( y , t' , py' ) + else + let t' = term_replace alpha x exp t in + let p' = if Var.equal x0 x then p else frec p in + Plet(x0,t',p') + end + | Pnamed(a,p) -> Pnamed(a,frec p) + +(* ------------------------------------------------------------------------ ) +( --- Quantification ) +( ------------------------------------------------------------------------ ) + +let fresh_vars_in_pred vars p = + let do_var (vars, p) v = + let v' = Var.fresh_var v in + let p = subst_in_pred v (e_var v') p in + v'::vars, p + in List.fold_left do_var ([], p) vars + +let p_forall_vars vars (p: pred) : pred = + let vars, p = fresh_vars_in_pred vars p in + List.fold_left (fun p v -> p_forall v p) p vars + +let p_exists_vars vars (p: pred) : pred = + let vars, p = fresh_vars_in_pred vars p in + List.fold_left (fun p v -> p_exists v p) p vars + +let rec term_calls f = function + | Tconst _ | Tvar _ -> false + | Tapp(g,ts) -> f=g || List.exists (term_calls f) ts + | Tgetfield(_,a) -> term_calls f a + | Tsetfield(_,a,b) | Taccess(a,b) | Tlet(_,a,b) -> + term_calls f a || term_calls f b + | Tupdate(a,b,c) | Tif(a,b,c) -> + term_calls f a || term_calls f b || term_calls f c + +let rec pred_calls f = function + | Ptrue | Pfalse -> false + | Papp(g,ts) -> f=g || List.exists (term_calls f) ts + | Pimplies(a,b) | Pand(a,b) | Por(a,b) | Piff(a,b) -> + pred_calls f a || pred_calls f b + | Pnamed(_,p) | Pnot p | Pforall(_,p) | Pexists(_,p) -> + pred_calls f p + | Pif(a,p,q) -> + term_calls f a || pred_calls f p || pred_calls f q + | Plet(_,a,p) -> + term_calls f a || pred_calls f p + +( ------------------------------------------------------------------------ ) +( --- Huge ) +( ------------------------------------------------------------------------ ) + +exception Huge + +let rec check_term m t = + if m < 0 then raise Huge ; + match t with + | Tconst _ | Tvar _ -> pred m + | Tapp(_,ts) -> List.fold_left check_term (pred m) ts + | Tgetfield(_,r) -> check_term (pred m) r + | Tsetfield(_,r,v) -> check_term (check_term (pred m) r) v + | Taccess(t,i) -> check_term (check_term (pred m) t) i + | Tupdate(t,i,v) -> check_term (check_term (check_term (pred m) t) i) v + | Tif(a,b,c) -> check_term (check_term (check_term (pred m) a) b) c + | Tlet(_,a,b) -> check_term (check_term (pred m) a) b + +let rec check_pred m p = + if m < 0 then raise Huge ; + match p with + | Ptrue | Pfalse -> pred m + | Papp(_,ts) -> List.fold_left check_term (pred m) ts + | Pimplies(a,b) | Pand(a,b) | Por(a,b) | Piff(a,b) -> check_pred (check_pred (pred m) a) b + | Pnamed(_,p) | Pnot p | Pforall(_,p) | Pexists(_,p) -> check_pred (pred m) p + | Pif(a,p,q) -> check_pred (check_pred (check_term (pred m) a) p) q + | Plet(_,t,p) -> check_pred (check_term (pred m) t) p + +let huge_term m t = try ignore (check_term m t) ; false with Huge -> true +let huge_pred m p = try ignore (check_pred m p) ; false with Huge -> true + +( ------------------------------------------------------------------------ ) + +type decl = (Var.t,term,pred) Formula.declaration + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol.mli frama-c-20111001+nitrogen+dfsg/src/wp/fol.mli --- frama-c-20110201+carbon+dfsg/src/wp/fol.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,164 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +type constant = private + | ConstInt of string + | ConstBool of bool + | ConstUnit + | ConstFloat of string + +val c_bool : bool -> constant +val c_int_of_str : string -> constant +val c_int : int -> constant +val c_float : float -> constant +val c_float_of_str : string -> constant + +( Fol Variable definition) +module Var : sig + + type t + ( = (string * int option * Formula.tau * Cil_types.logic_type option) ) + + val mk : + string -> int option -> Formula.tau -> Cil_types.logic_type option -> t + val ident_named_var : string -> int -> Formula.tau -> t + val fresh_named_var : string -> Formula.tau -> t + val fresh_var : t -> t + val var_type : t -> Formula.tau + val var_name : t -> string + val basename : t -> string + val kind_of_var : t -> Formula.kind + val equal : t -> t -> bool + val compare : t -> t -> int + +end + +module Vset : Set.S with type elt = Var.t +module Vmap : Map.S with type key = Var.t + +(----------------------------------------------------------------------------*) +(** Terms ) + +type term = private + | Tconst of constant + | Tvar of Var.t + | Tapp of string term list + | Tgetfield of Cil_types.fieldinfo * term + | Tsetfield of Cil_types.fieldinfo * term * term + | Taccess of term * term + | Tupdate of term * term * term + | Tif of term * term * term + | Tlet of Var.t * term * term + +val e_true : term +val e_false : term +val e_int : int -> term +val e_int64 : int64 -> term +val e_float : float -> term +val e_cnst : constant -> term +val e_var : Var.t -> term +val e_if : term -> term -> term -> term +val e_app : string -> term list -> term +val e_getfield : Cil_types.fieldinfo -> term -> term +val e_setfield : Cil_types.fieldinfo -> term -> term -> term + +val e_access : term -> term -> term +val e_update : term -> term -> term -> term +val e_let : Var.t -> term -> term -> term + +val change_in_exp : (Var.t -> term option) -> term -> term +val term_replace : (Var.t -> Var.t option) -> Var.t -> term ->term -> term + +(----------------------------------------------------------------------------) +(** Predicates ) + +type pred = + | Papp of string term list + | Ptrue + | Pfalse + | Pimplies of pred * pred + | Pif of term * pred * pred + | Pand of pred * pred + | Por of pred * pred + | Piff of pred * pred + | Pnot of pred + | Pforall of Var.t * pred + | Pexists of Var.t * pred + | Plet of Var.t * term * pred + | Pnamed of string * pred + +val eq_terms : term -> term -> bool (** structural equality *) +val eq_preds : pred -> pred -> bool (** (partial) structural equality *) + +val p_and : pred -> pred -> pred +val p_app: string -> term list -> pred +val p_or : pred -> pred -> pred +val p_xor : pred -> pred -> pred +val p_iff : pred -> pred -> pred +val p_not : pred -> pred +val p_if : term -> pred -> pred -> pred +val p_implies: pred -> pred -> pred +val p_conj : pred list -> pred +val p_disj : pred list -> pred + +val p_eq : term -> term -> pred +val p_neq : term -> term -> pred + +val p_forall : Var.t -> pred -> pred +val p_exists : Var.t -> pred -> pred +val p_let : Var.t -> term -> pred -> pred +val p_named : string -> pred -> pred + +val is_true : pred -> bool +val is_false : pred -> bool + +val e_has_var : Var.t list -> term -> bool +val p_has_var : Var.t list -> pred -> bool +val e_closed : Var.t list -> term -> bool +val p_closed : Var.t list -> pred -> bool + +val term_calls : string -> term -> bool +val pred_calls : string -> pred -> bool + +val subst_in_pred : Var.t -> term -> pred -> pred +val pred_replace : (Var.t -> Var.t option) -> Var.t -> term -> pred -> pred + +val let_pred : fresh:bool -> Var.t -> term -> pred -> pred + +val p_forall_vars : Var.t list -> pred -> pred + +val p_exists_vars : Var.t list -> pred -> pred + + +(** [pred_alpha_c data_alpha alpha p] -> [alpha', p']) +val pred_alpha_cv : Var.t Vmap.t -> pred -> Var.t Vmap.t pred + +val p_alpha_cv : pred -> Var.t list * pred + +(----------------------------------------------------------------------------) +val huge_term : int -> term -> bool +val huge_pred : int -> pred -> bool +(----------------------------------------------------------------------------) + +type decl = (Var.t,term,pred) Formula.declaration + +val pp_term : (Format.formatter -> term -> unit) ref diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_norm.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_norm.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_norm.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_norm.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,34 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Fol + +type normalized = + | Pred of pred + | Conv of Fol_cc.f_let list * pred + +let compile p = + match Wp_parameters.get_norm () with + | Wp_parameters.Let -> Pred p + | Wp_parameters.Exp -> Pred (Fol_eval.plet_expansion p) + | Wp_parameters.Cc -> let defs,p = Fol_cc.unlet p in Conv (defs,p) + | Wp_parameters.Eqs -> Pred (Fol_eqs.compile p) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_norm.mli frama-c-20111001+nitrogen+dfsg/src/wp/fol_norm.mli --- frama-c-20110201+carbon+dfsg/src/wp/fol_norm.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_norm.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,29 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Fol + +type normalized = + | Pred of pred + | Conv of Fol_cc.f_let list * pred + +val compile : pred -> normalized diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_pretty.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_pretty.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_pretty.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_pretty.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,377 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cilutil + + + + +let f_suffixe f = (f.Cil_types.fname)^"_"^(f.Cil_types.fcomp.Cil_types.cname) +let get_field f = "get_"^(f_suffixe f) +let set_field f = "set_"^(f_suffixe f) + + + +(* ---------------------------------------------------------------------- ) +( --- Output Utilities --- ) +( ---------------------------------------------------------------------- ) + + + +let constant fmt = function + | Fol.ConstInt n -> Format.pp_print_string fmt n + | Fol.ConstBool b -> Format.pp_print_string fmt (if b then "true" else "false") + | Fol.ConstUnit -> Format.pp_print_string fmt "void" + | Fol.ConstFloat f -> Format.pp_print_string fmt f + +let pp_list pp fmt = function + | [] -> () + | x::xs -> + pp fmt x ; + List.iter (fun x -> Format.fprintf fmt ",@,%a" pp x) xs + +let pp_flow fmt nil op pp = function + | [] -> + Format.pp_print_string fmt nil + | x::xs -> + Format.fprintf fmt "@[<hov 1>(%a" pp x ; + List.iter (fun x -> Format.fprintf fmt "@,%s%a" op pp x) xs ; + Format.fprintf fmt ")@]" + + +let pp_block fmt op pp ps = + Pretty_utils.pp_list + ~pre:"@[<hv>" ~sep:("@ " ^^ op ^^ "@ ") ~suf:"@]" + pp fmt ps + +let pp_block_implies fmt op pp ps = + Pretty_utils.pp_list + ~pre:"@[<v>" ~sep:(" " ^^ op ^^ "@ ") ~suf:"@]" + pp fmt ps + +let pp_var fmt v = + let name = Fol_decl.identifier (Fol.Var.var_name v) in + Format.fprintf fmt "%s" name + +let rec collect_assoc op xs = function + | [] -> List.rev xs + | Fol.Tapp(id,ts) :: others when id = op -> + collect_assoc op (collect_assoc op xs ts) others + | t::others -> + collect_assoc op (t::xs) others + +let fpp_term term fmt t = + match t with + | Fol.Tconst c -> constant fmt c + | Fol.Tvar v -> pp_var fmt v + | Fol.Tapp (id, []) -> Format.pp_print_string fmt id + | Fol.Tapp ("ite",[c;a;b]) | Fol.Tif (c,a,b) -> + Format.fprintf fmt "(@[<hv>if %a@ then %a@ else %a@])" + term c term a term b + + ( INT ) + | Fol.Tapp ("neg_int", [t]) -> + Format.fprintf fmt "@[<hov 1>(-%a)@]" term t + | Fol.Tapp ("add_int", ts) -> + let xs = collect_assoc "add_int" [] ts in + pp_flow fmt "0" "+" term xs + | Fol.Tapp ("sub_int", [a;b]) -> + Format.fprintf fmt "@[<hov 1>(%a@,-%a)@]" term a term b + | Fol.Tapp ("mul_int", ts) -> + let xs = collect_assoc "mul_int" [] ts in + pp_flow fmt "1" "" term xs + + (* REAL ) + | Fol.Tapp ("neg_real", [t]) -> + Format.fprintf fmt "@[<hov 1>(-%a)@]" term t + | Fol.Tapp ("add_real", ts) -> + let xs = collect_assoc "add_real" [] ts in + pp_flow fmt "0.0" "+" term xs + | Fol.Tapp ("sub_real", [a;b]) -> + Format.fprintf fmt "@[<hov 1>(%a@,-%a)@]" term a term b + | Fol.Tapp ("mul_real", ts) -> + let xs = collect_assoc "mul_real" [] ts in + pp_flow fmt "1.0" "" term xs + | Fol.Tapp ("div_real", [a;b]) -> + Format.fprintf fmt "@[<hov 1>(%a@,/%a)@]" term a term b + + | Fol.Tapp (id, t::ts) -> + Format.fprintf fmt "@[<hov 2>%s(@,%a" id term t ; + List.iter (fun t -> Format.fprintf fmt ",@,%a" term t) ts ; + Format.fprintf fmt ")@]" + | Fol.Tlet (x,v,t) -> + Format.fprintf fmt "(@[<hv 0>let %a@ = %a@ in %a@])" + pp_var x term v term t + | Fol.Taccess(a,k) -> Format.fprintf fmt "access(%a,@,%a)" term a term k + | Fol.Tupdate(a,k,b) -> + Format.fprintf fmt "@[<hv 2>update(%a,@,%a,@,%a)@]" + term a term k term b + + | Fol.Tgetfield (f,r) -> + Format.fprintf fmt "@[<hv 2>%s(%a)@]" (get_field f) term r + | Fol.Tsetfield (f,r,v) -> + Format.fprintf fmt "@[<hv 2>%s(%a,@,%a)@]" (set_field f) + term r term v + + +let fpretty_term term fmt t = + if Wp_parameters.verbose_atleast 2 + then fpp_term term fmt t + else match t with + | Fol.Tapp(("encode"|"decode"),[_;v]) -> + Format.fprintf fmt "{%a}" term v + | Fol.Taccess(a,k) -> Format.fprintf fmt "%a[%a]" term a term k + | Fol.Tupdate(a,k,b) -> + Format.fprintf fmt "@[<hv 2>%a[%a@,->%a]@]" + term a term k term b + + | t -> + fpp_term term fmt t + +let rec collect_or ps = function + | Fol.Por(a,b) -> collect_or (collect_or ps b) a + | p -> p :: ps + +let rec collect_and ps = function + | Fol.Pand(a,b) -> collect_and (collect_and ps b) a + | p -> p :: ps + +let rec collect_imply ps = function + | Fol.Pimplies(a,b) -> collect_and (collect_imply ps b) a + | p -> p :: ps + +let rec collect_iff ps = function + | Fol.Piff(a,b) -> collect_iff (collect_iff ps b) a + | p -> p :: ps + +type 'a pp = Format.formatter -> 'a -> unit +type pp_env = { + pp_type : Formula.tau pp ; + pp_term : Fol.term pp ; + pp_pred : Fol.pred pp ; +} + +(TODO : ensures that label are different from keywords of the host language) +let tag_named tag = "tag_"^tag + + +let pp_tau = Fol_decl.Tau.pp_tau + +let rec epp_pred_vbox env fmt p = + match p with + | Fol.Pand _ -> pp_block fmt "and" env.pp_pred (collect_and [] p) + | Fol.Por _ -> pp_block fmt "or" env.pp_pred (collect_or [] p) + | Fol.Pimplies _ -> + pp_block_implies fmt "->" env.pp_pred (collect_imply [] p) + | Fol.Piff _ -> pp_block fmt "<->" env.pp_pred (collect_iff [] p) + | Fol.Pforall(x,p) -> + Format.fprintf fmt "forall %a:%a.@\n" pp_var x env.pp_type (Fol.Var.var_type x) ; + epp_pred_vbox env fmt p + | Fol.Pexists(x,p) -> + Format.fprintf fmt "exists %a:%a.@\n" pp_var x env.pp_type (Fol.Var.var_type x) ; + epp_pred_vbox env fmt p + | Fol.Plet(x,t,p) -> + Format.fprintf fmt "@[<hov 2>let %a =@ %a@ in@]@\n" pp_var x env.pp_term t ; + epp_pred_vbox env fmt p + | Fol.Pif(t,p,q) -> + Format.fprintf fmt "@[<hov 0>if @[<hov 2>%a@]@ then@]@\n %a@\nelse@\n %a" + env.pp_term t env.pp_pred p env.pp_pred q + | (Fol.Ptrue | Fol.Pfalse | Fol.Papp _ | Fol.Pnot _ | Fol.Pnamed _) -> + env.pp_pred fmt p + +let rec epp_pred_atom env fmt p = + match p with + | Fol.Pand _ | Fol.Por _ | Fol.Pimplies _ | Fol.Piff _ | Fol.Pif _ + | Fol.Pforall _ | Fol.Pexists _ | Fol.Plet _ -> + Format.fprintf fmt "@[<v 1>(%a)@]" (epp_pred_vbox env) p + | Fol.Pnot p -> + Format.fprintf fmt "@[<hov 2>(not@ %a)@]" (epp_pred_atom env) p + | Fol.Ptrue -> Format.pp_print_string fmt "true" + | Fol.Pfalse -> Format.pp_print_string fmt "false" + | Fol.Papp(id,[]) -> Format.pp_print_string fmt id + | Fol.Papp (("eq" | "eq_int" | "eq_real"), [t1; t2]) -> + Format.fprintf fmt "@[<hov 1>(%a@ =@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp (("neq" | "neq_int"| "neq_real"), [t1; t2]) -> + Format.fprintf fmt "@[<hov 1>(%a@ <>@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp (("lt_int"| "lt_real"), [t1; t2]) -> + Format.fprintf fmt "@[<hov 1>(%a@ <@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp (("le_int"| "le_real"), [t1; t2]) -> + Format.fprintf fmt "@[<hov 1>(%a@ <=@ %a)@]" env.pp_term t1 env.pp_term t2 + | Fol.Papp(id,t::ts) -> + Format.fprintf fmt "@[<hov 2>%s(@,%a" id env.pp_term t ; + List.iter (fun t -> Format.fprintf fmt ",@ %a" env.pp_term t) ts ; + Format.fprintf fmt ")@]" + | Fol.Pnamed(tag,p) -> + Format.fprintf fmt "@[<hov 0>@[<hov 0>%s:%a@]" + (tag_named tag) (epp_pred_named env) p + +and epp_pred_named env fmt = function + | Fol.Pnamed(tag,p) -> + Format.fprintf fmt "@,%s:" (tag_named tag) ; + epp_pred_named env fmt p + | p -> + Format.fprintf fmt "@]@,%a" (epp_pred_atom env) p + +let fpp_pred predicate pp_tau pp_term fmt p = + match p with + | Fol.Ptrue -> Format.fprintf fmt "true" + | Fol.Pfalse -> Format.fprintf fmt "false" + | Fol.Papp (id, [])-> Format.fprintf fmt "%s" id + | Fol.Papp ("eq", [t1; t2]) -> Format.fprintf fmt "(%a =@ %a)" pp_term t1 pp_term t2 + | Fol.Papp ("neq", [t1; t2]) -> Format.fprintf fmt "(%a <>@ %a)" pp_term t1 pp_term t2 + | Fol.Papp (id, l) -> Format.fprintf fmt "@[%s(%a)@]" id (pp_list pp_term) l + | Fol.Pimplies (a, b) -> Format.fprintf fmt "(@[%a ->@ %a@])" predicate a predicate b + | Fol.Piff (a, b) -> Format.fprintf fmt "(@[%a <->@ %a@])" predicate a predicate b + | Fol.Pand (a, b) -> Format.fprintf fmt "(@[%a and@ %a@])" predicate a predicate b + | Fol.Por (a, b) -> Format.fprintf fmt "(@[%a or@ %a@])" predicate a predicate b + | Fol.Pnot a -> Format.fprintf fmt "(not %a)" predicate a + | Fol.Pif (a, b, c) -> + Format.fprintf fmt "(@[if %a then@ %a else@ %a@])" + pp_term a predicate b predicate c + | Fol.Pforall (v,p) -> + Format.fprintf fmt "@[<hov 0>(forall %a:%a.@ %a@])" + pp_var v pp_tau (Fol.Var.var_type v) predicate p + | Fol.Pexists (v,p) -> + Format.fprintf fmt "@[<hov 0>(exists %a:%a.@ %a@])" + pp_var v pp_tau (Fol.Var.var_type v) predicate p + | Fol.Plet (x,v,p) -> + Format.fprintf fmt "@[<hov 0>(let %a =@[<hov 2>@ %a@ in@]@ %a@])" + pp_var x pp_term v predicate p + | Fol.Pnamed (n, p) -> + Format.fprintf fmt "@[%s: %a@]" (tag_named n) predicate p + + +let export_get_set_field fmt pp_tau f = + let cn = f.Cil_types.fcomp.Cil_types.cname in + let fn = Fol_decl.Tau.tau_of_ctype_logic f.Cil_types.ftype in + let get_f = get_field f in + let set_f = set_field f in + Format.fprintf fmt "logic %s: %s -> %a @\n" get_f cn pp_tau fn; + Format.fprintf fmt "logic %s: %s , %a -> %s @\n" set_f cn pp_tau fn cn + + +let export_get_set_other fmt pp_tau f get_f g = + let set_g = set_field g in + Format.pp_print_newline fmt () ; + Format.fprintf fmt + "(* Definition of the commutativity of the get field %s over the set field %s)@\n" + f.Cil_types.fname g.Cil_types.fname; + Format.pp_print_newline fmt () ; + Format.fprintf fmt "axiom GetSetOther_%s_%s@,:@\n" f.Cil_types.fname g.Cil_types.fname; + Format.fprintf fmt "forall r:%s.@,forall v:%a.@\n" + f.Cil_types.fcomp.Cil_types.cname + pp_tau (Fol_decl.Tau.tau_of_ctype_logic g.Cil_types.ftype); + Format.fprintf fmt "%s(%s(r,v))@,=@, %s(r)@\n" get_f set_g get_f; + Format.pp_print_newline fmt () + +let export_generated_axiomatics fmt pp_tau f = + let get_f = get_field f in + let set_f = set_field f in + Format.fprintf fmt + "( Definition of the good properties of the field %s*)@\n" f.Cil_types.fname; + Format.pp_print_newline fmt () ; + Format.fprintf fmt "axiom GetSetSame_%s@,:@\n" f.Cil_types.fname; + Format.fprintf fmt "forall r:%s.@,forall v:%a.@\n" + f.Cil_types.fcomp.Cil_types.cname + pp_tau (Fol_decl.Tau.tau_of_ctype_logic f.Cil_types.ftype); + Format.fprintf fmt "%s(%s(r,v))@,=@, v@\n" get_f set_f ; + Format.pp_print_newline fmt () ; + if f.Cil_types.fcomp.Cil_types.cstruct then + (List.iter (fun g -> + if Cil_datatype.Fieldinfo.equal f g then () else + export_get_set_other fmt pp_tau f get_f g) + f.Cil_types.fcomp.Cil_types.cfields ;) + else (); + Format.pp_print_newline fmt () ; + Format.pp_print_newline fmt () + +let pp_section fmt title = + begin + Format.fprintf fmt "----------------------------------------@\n" ; + Format.fprintf fmt "--- %s@\n" title ; + Format.fprintf fmt "----------------------------------------@\n@\n" ; + end + +let pp_param pp_tau fmt x = + Format.fprintf fmt "%a:%a" pp_var x pp_tau (Fol.Var.var_type x) + +let fpp_item term predicate pp_tau fmt x = + function + | Formula.Cons k -> + Format.fprintf fmt "function %s () : int = %d@\n" x k + | Formula.Function ([], t) -> + Format.fprintf fmt "logic %s: %a@\n" x pp_tau t + | Formula.Function (tl, t) -> + Format.fprintf fmt "logic %s: @[<hov 0>%a -> %a@]@\n" x (pp_list pp_tau) tl pp_tau t + | Formula.Predicate([]) -> + Format.fprintf fmt "logic %s: prop@\n" x + | Formula.Predicate(tl) -> + Format.fprintf fmt "logic %s: @[<hov 0>%a -> prop@]@\n" x (pp_list pp_tau) tl + | Formula.FunctionDef (xs,tr,exp) -> + Format.fprintf fmt "@[<hv 2>function %s (%a) : %a =@ @[<hov 0>%a@]@]@\n" + x (pp_list (pp_param pp_tau)) xs pp_tau tr term exp + | Formula.PredicateDef(xs,p) -> + Format.fprintf fmt "@[<hv 2>predicate %s (%a) =@ @[<hov 0>%a@]@]@\n" + x (pp_list (pp_param pp_tau)) xs predicate p + | Formula.Axiom p -> + Format.fprintf fmt "@[<hv 2>axiom %s:@ %a@]@\n" x predicate p + | Formula.Type 0 -> + Format.fprintf fmt "type %s@\n" x + | Formula.Type 1 -> + Format.fprintf fmt "type 'a %s@\n" x + | Formula.Type n -> + Format.fprintf fmt "@[<hov 2>type ('a" ; + for k=2 to n do Format.fprintf fmt ",%c" (char_of_int (int_of_char 'a'+k-1)) done ; + Format.fprintf fmt ") %s@]@\n" x + | Formula.Trecord c -> + begin + Format.fprintf fmt "type %s@\n" c.Cil_types.cname ; + let l = c.Cil_types.cfields in + List.iter (fun f -> export_get_set_field fmt pp_tau f) l ; + List.iter (fun f -> export_generated_axiomatics fmt pp_tau f) l + end + +let fpp_header fmt d = + begin + d.Formula.d_title fmt ; + Format.pp_print_newline fmt () ; + ( match d.Formula.d_source with + | Some { Lexing.pos_fname=f ; pos_lnum=k } -> + Format.fprintf fmt "%s:%d: " f k + | None -> () ) ; + d.Formula.d_descr fmt ; + end + +let fpp_decl term predicate fmt d = + begin + fpp_header fmt d ; + Format.pp_print_newline fmt () ; + fpp_item term predicate pp_tau fmt d.Formula.d_name d.Formula.d_item ; + Format.pp_print_newline fmt () ; + end + +let fpp_goal predicate fmt x p = + Format.fprintf fmt "@[<hv 2>goal %s:@ %a@]@." x predicate p; + + + + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_split.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_split.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_split.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_split.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,216 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +let dkey = "split" (* Debugging key ) + +( ------------------------------------------------------------------------ ) +( --- Splitter for FOL --- ) +( ------------------------------------------------------------------------ ) + +open Fol + + +module Env = Map.Make(Fol.Var) + +type term = Fol.term +type pred = Fol.pred + +let is_zone = function + | Tapp(s,_) -> List.mem s + [ "zunion" ; "zempty" ; "zrange" ; + "zrange_of_addr" ; "zrange_of_addr_range" ; + "zs_empty" ; "zs_singleton" ; "zs_union" ; + ] + | _ -> false + +let rec e_unfold env = function + | Tvar x as t -> (try Env.find x env with Not_found -> t) + | Tlet(x,a,b) -> + let a0 = e_unfold env a in + if is_zone a0 + then e_unfold (Env.add x a0 env) b + else e_let x a0 (e_unfold (Env.remove x env) b) + | Tapp(f,xs) -> e_app f (List.map (e_unfold env) xs) + | Taccess(t,i) -> e_access (e_unfold env t) (e_unfold env i) + | Tupdate(t,i,v) -> e_update (e_unfold env t) ( e_unfold env i) (e_unfold env v) + | Tgetfield(f,r) -> e_getfield f (e_unfold env r) + | Tsetfield(f,r,v) -> e_setfield f (e_unfold env r) (e_unfold env v) + | Tif(c,a,b) -> e_if (e_unfold env c) (e_unfold env a) (e_unfold env b) + | Tconst _ as t -> t + +let rec p_unfold env = function + | Plet(x,t,p) -> + let t0 = e_unfold env t in + if is_zone t0 + then p_unfold (Env.add x t0 env) p + else p_let x t0 (p_unfold (Env.remove x env) p) + | Pnamed(a,p) -> Pnamed(a,p_unfold env p) + | (Ptrue | Pfalse) as p -> p + | Papp(f,es) -> p_app f (List.map (e_unfold env) es) + | Pimplies(p,q) -> p_implies (p_unfold env p) (p_unfold env q) + | Pif(c,p,q) -> p_if (e_unfold env c) (p_unfold env p) (p_unfold env q) + | Pand(p,q) -> p_and (p_unfold env p) (p_unfold env q) + | Por(p,q) -> p_or (p_unfold env p) (p_unfold env q) + | Piff(p,q) -> p_iff (p_unfold env p) (p_unfold env q) + | Pnot p -> p_not (p_unfold env p) + | Pforall(x,p) -> p_forall x (p_unfold env p) + | Pexists(x,p) -> p_exists x (p_unfold env p) + +( ------------------------------------------------------------------------ ) +( --- Case Split --- ) +( ------------------------------------------------------------------------ ) + +module SplitZoneInclusion (M : + sig + val union : string ( symbol for union ) + val empty : string ( symbol for empty ) + val included : string ( symbol for inclusion ) + end) + = +struct + + let rec flatten xs = function + | Tapp( f , es ) when f = M.union -> List.fold_left flatten xs es + | Tapp( f , [] ) when f = M.empty -> xs + | t -> t::xs + + let rec zunion = function + | [z] -> z + | [] -> e_app M.empty [] + | z::zs -> e_app M.union [ z ; zunion zs ] + + let included a b = + let zas = flatten [] a in + let zbs = flatten [] b in + let zb = zunion zbs in + List.fold_left + (fun acc z -> + if Wp_parameters.Simpl.get () && List.exists (Fol.eq_terms z) zbs + then acc + else Bag.add (p_app M.included [z;zb]) acc) + Bag.empty zas + +end + +module StoreInclusion = SplitZoneInclusion + (struct + let union = "zunion" + let empty = "zempty" + let included = "included" + end) + +module RuntimeInclusion = SplitZoneInclusion + (struct + let union = "zs_union" + let empty = "zs_empty" + let included = "zs_incl" + end) + +( Do not bound the depth when [max_depth]=0, + otherwise, the spliting is pruned and [max_split] bound may be not reached. ) +let dispatch max_depth max_split p = + let rec nb_splits = ref 1 + + and concat depth pol orig d1 b1 d2 b2 = + let rec incr_depth kid = + ( sometime, depth is not incremented ) + match orig, kid with + | _, Pnamed(_,p) -> incr_depth p + | Por _, Por _ -> depth + | Pand _, Pand _ -> depth + | _, _ -> depth + 1 + in + if (!nb_splits >= max_split) || ((depth >= max_depth) && (max_depth <> 0)) + then Bag.elt (if pol then orig else (p_not orig)) + else (incr nb_splits ; Bag.concat (d1 (incr_depth b1) b1) (d2 (incr_depth b2) b2)) + + and choose p bag = + let nb = !nb_splits + (Bag.length bag) - 1 + in if nb >= max_split + then Bag.elt p + else (nb_splits := nb ; bag) + + and concat_if depth pol orig d c p q = + if (!nb_splits >= max_split) || ((depth >= max_depth) && (max_depth <> 0)) + then Bag.elt (if pol then orig else (p_not orig)) + else (incr nb_splits ; + Bag.concat + (Bag.map (fun p -> p_implies (p_eq c e_true) p) (d (depth+1) p)) + (Bag.map (fun q -> p_implies (p_eq c e_false) q) (d (depth+1) q))) + + and dispatch_neg depth = function + | Pfalse -> Bag.empty + | Pnot p -> dispatch_pos depth p + | (Ptrue|Pand _|Piff _|Papp _ |Pforall _) as p -> Bag.elt (p_not p) + | Por(p,q) as full -> concat depth false full dispatch_neg p dispatch_neg q + | Pimplies(h,p)as full -> concat depth false full dispatch_pos h dispatch_neg p + | Pif(c,p,q) as full -> concat_if depth false full dispatch_neg c p q + | Pnamed(a,p) -> Bag.map (fun p -> Pnamed(a,p)) (dispatch_neg depth p) + | Pexists(x,p) -> Bag.map (p_forall x) (dispatch_neg depth p) + | Plet(x,t,p) -> Bag.map (p_let x t) (dispatch_neg depth p) + + and dispatch_pos depth = function + | Ptrue -> Bag.empty + | Pnot p -> dispatch_neg depth p + | Papp( "included" , [a;b]) as p -> choose p (StoreInclusion.included a b) + | Papp( "zs_incl" , [a;b]) as p -> choose p (RuntimeInclusion.included a b) + + | (Pfalse|Por _|Piff _|Papp _ |Pexists _) as p -> Bag.elt p + | Pimplies(h,p) -> Bag.map (fun p -> p_implies h p) (dispatch_pos depth p) + | Pand(p,q) as full -> concat depth true full dispatch_pos p dispatch_pos q + | Pif(c,p,q) as full -> concat_if depth true full dispatch_pos c p q + | Pnamed(a,p) -> Bag.map (fun p -> Pnamed(a,p)) (dispatch_pos depth p) + | Pforall(x,p) -> Bag.map (p_forall x) (dispatch_pos depth p) + | Plet(x,t,p) -> Bag.map (p_let x t) (dispatch_pos depth p) + in + + dispatch_pos 1 p + +( ------------------------------------------------------------------------ ) +( --- Splitter Interface --- ) +( ------------------------------------------------------------------------ ) + +let simplify = Fol_let.compile + +( [split] may deliver stronger sub-predicates ) +let split meth p = + let nb = Wp_parameters.SplitDim.get() + in let max_depth = if nb < 0 then 0 ( <- do not prune the search ) else (2 + nb) + and max_split = ( 2**|nb| ) + try + Big_int.int_of_big_int (Big_int.power_int_positive_int 2 (if nb < 0 then -nb else nb)) + with (Invalid_argument _ | Failure _) -> + Wp_parameters.debug ~dkey "Invalid value for option %s@." Wp_parameters.SplitDim.name; + 0 ( <- do not split ) + in + let bag = + match meth with + | Mcfg.EffectAssigns -> dispatch max_depth max_split (p_unfold Env.empty p) + | _ -> dispatch max_depth max_split p + in let nb = Bag.length bag + ( TODO: + if the bag is not full and [max_depth]<>0 + then it could be possible to iter once more + on the elements of the bag with [max_depth]=0 *) + in if nb > 1 then + Wp_parameters.debug ~dkey "Predicate splited into %d parts@." nb; + bag diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_split.mli frama-c-20111001+nitrogen+dfsg/src/wp/fol_split.mli --- frama-c-20110201+carbon+dfsg/src/wp/fol_split.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_split.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,43 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ *) +(** Splitting Goals ) +( ------------------------------------------------------------------------ *) + +(** {2 Zone-unions Flattening} + The [unfolding] methods below only applies to variables that holds + a union of [zone] values. Other variables are left letified. *) + +module Env : Map.S with type key = Fol.Var.t + +val e_unfold : Fol.term Env.t -> Fol.term -> Fol.term +val p_unfold : Fol.term Env.t -> Fol.pred -> Fol.pred + +(** {2 Splitter Interface} *) + +type pred = Fol.pred +val simplify : pred -> pred +val split : Mcfg.assigns_method -> pred -> pred Bag.t + (** First, unfold zones when method is effect-assigns. + Then applies [dispatch]. + Note: [split] may deliver stronger sub-predicates *) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/fol_why.ml frama-c-20111001+nitrogen+dfsg/src/wp/fol_why.ml --- frama-c-20110201+carbon+dfsg/src/wp/fol_why.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/fol_why.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,88 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- WHY Export --- ) +( -------------------------------------------------------------------------- ) + + +module EWhy (L:sig val tau_of_ctype_logic : Cil_types.typ -> Formula.tau end)= +struct + +type pred = Fol.pred +type decl = Fol.decl + +let rec export_tau fmt = function + | Formula.Integer -> Format.pp_print_string fmt "int" + | Formula.Real -> Format.pp_print_string fmt "real" + | Formula.Boolean -> Format.pp_print_string fmt "bool" + | Formula.Pointer t -> export_tau fmt t + | Formula.Record c -> Format.fprintf fmt "%s" c.Cil_types.cname + | Formula.Array arr -> + let t = L.tau_of_ctype_logic arr.Ctypes.arr_element in + Format.fprintf fmt "%a farray" export_tau t + | Formula.Set te -> + Format.fprintf fmt "%a set" export_tau te + | Formula.ADT(s,[]) -> Format.pp_print_string fmt s + | Formula.ADT(s,[t]) -> Format.fprintf fmt "%a %s" export_tau t s + | Formula.ADT(s,t::ts) -> + Format.fprintf fmt "@[(%a" export_tau t ; + List.iter (fun t -> Format.fprintf fmt ",@,%a" export_tau t) ts ; + Format.fprintf fmt ") %s@]" s + +let rec export_term fmt t = Fol_pretty.fpp_term export_term fmt t + + +let rec pp_pred_atom fmt p = + Fol_pretty.epp_pred_atom { + Fol_pretty.pp_type = export_tau ; + Fol_pretty.pp_term = export_term ; + Fol_pretty.pp_pred = pp_pred_atom; + } fmt p + +let export_pred fmt p = + Fol_pretty.epp_pred_vbox { + Fol_pretty.pp_type = export_tau ; + Fol_pretty.pp_term = export_term ; + Fol_pretty.pp_pred = pp_pred_atom ; + } fmt p + + +let export_section fmt title = + begin + Format.fprintf fmt "(----------------------------------------)@\n" ; + Format.fprintf fmt "(--- %-32s ---)@\n" title ; + Format.fprintf fmt "(----------------------------------------*)@\n" ; + end + +let export_item fmt name item = + Fol_pretty.fpp_item export_term export_pred export_tau fmt name item + +let export_decl fmt d = + Pretty_utils.pp_trail Fol_pretty.fpp_header fmt d ; + Format.pp_print_newline fmt () ; + export_item fmt d.Formula.d_name d.Formula.d_item + +let export_goal fmt x g = + Fol_pretty.fpp_goal export_pred fmt x g; + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/formula.mli frama-c-20111001+nitrogen+dfsg/src/wp/formula.mli --- frama-c-20110201+carbon+dfsg/src/wp/formula.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/formula.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,519 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + + +open Cil_types +open Ctypes + + +(* -------------------------------------------------------------------------- *) +(** Logic Formulae ) +( -------------------------------------------------------------------------- *) + +(** {2 Logic types }) + +type tau = + | Integer + | Real + | Boolean + | Pointer of tau + | Set of tau + | Record of Cil_types.compinfo + | Array of Ctypes.arrayinfo + | ADT of string (tau list) + +type kind = + | Model of tau + | Acsl of tau * Cil_types.logic_type + + + +(** {2 Pure types} *) + +type m_boolean (** The set of two elements [{true,false}]. *) +type m_integer (** Natural signed integers ({b Z}). *) +type m_real (** Real numbers ({b R}). *) +type m_abstract (** Abstract Data Types (user-defined WHY-types). *) + +type m_name (** type name [data_lib.why] *) + +type m_pointer (** type pointer [data_lib.why] *) +type m_array (** type 'a farray [array.why] *) +type m_record (** type record [data_lib.why] *) +type m_urecord (** type urecord [data_lib.why] *) +type m_set (** type 'a set [data_lib.why] *) +type m_zone (** type of elementary regions *) + + + +(** {2 Arithmetics Operators} *) + +type int_op = Iadd | Isub | Imul | Idiv | Imod +type real_op = Radd | Rsub | Rmul | Rdiv +type cmp_op = Ceq | Cneq | Clt | Cleq + +(** {2 Declarations} *) + +type section = + | S_Type (** LOGIC type definition *) + | S_Cons (** LOGIC type constructor *) + | S_Logic_Sig (** Signature of Functions and Predicates *) + | S_Logic_Def (** Definitions for Functions and Predicates *) + | S_Logic_Prop (** Axioms on Functions and Predicates *) + | S_Model_Sig (** Signature of Functions and Predicates *) + | S_Model_Def (** Definitions for Functions and Predicates *) + | S_Model_Prop (** Axioms on Functions and Predicates *) + | S_User_Sig (** Signature of User-defined function and predicates *) + | S_User_Prop (** Axioms on User-defined function and predicates ) + +type ('x,'t,'p) item = + | Type of int + | Cons of int + | Function of tau list tau + | Predicate of tau list + | FunctionDef of 'x list * tau * 't + | PredicateDef of 'x list * 'p + | Axiom of 'p + | Trecord of compinfo + +type ('x,'t,'p) declaration = + { + d_section : section ; + d_name : string ; + d_title : (Format.formatter -> unit) ; + d_descr : (Format.formatter -> unit) ; + d_source : Lexing.position option ; + d_item : ('x,'t,'p) item ; + } + +(** {2 Signature for logic formulae} *) + +module type S = +sig + + type var + type 'a term + type pred + + + type abstract = m_abstract term + type integer = m_integer term + type real = m_real term + type boolean = m_boolean term + type record = m_record term + type urecord = m_array term + type array = m_array term + type set = m_set term + type name = m_integer term + + type decl = (var,abstract,pred) declaration + + val e_int : int -> integer + val e_call : string -> abstract list -> abstract + val p_call : string -> abstract list -> pred + val wrap : 'a term -> abstract + val unwrap : abstract -> 'a term + + (** {2 Global Declarations} *) + + val clear : unit -> unit + val on_clear : (unit -> unit) -> unit + val fresh_name : string -> string -> string + val add_declaration : decl -> unit + val has_declaration : string -> bool + val iter_all : (string -> unit) -> (decl -> unit) -> unit + + (** {2 Functors and Types for Declaration} *) + + module type Identifiable = + sig + type t + module H : Hashtbl.S + val index : t -> H.key + val prefix : string + val basename : t -> string + val location : t -> Lexing.position option + val pp_title : Format.formatter -> t -> unit + val pp_descr : Format.formatter -> t -> unit + end + + module type Registry = + sig + type t + val define : t -> unit + val get_definition : t -> decl + val on_definition : (t -> decl -> unit) -> unit + end + + module type Declarator = + sig + include Identifiable + val clear : unit -> unit + val section : section + val declare : t -> string -> (var,abstract,pred) item + end + + module DRegister + (D : Declarator) : + (Registry with type t = D.t) + + (** {2 Build-int Identifiables and Registry} ) + + module Varinfo : Identifiable with type t = varinfo + module Varaddr : Identifiable with type t = varinfo + module Fieldinfo : Identifiable with type t = fieldinfo + module Compinfo : Identifiable with type t = compinfo + module Arrayinfo : Identifiable with type t = arrayinfo + module Logicvar : Identifiable with type t = logic_var + module LTypeinfo : Identifiable with type t = logic_type + module Cobject : Identifiable with type t = Ctypes.c_object + module ArrayDim : Identifiable with type t = Ctypes.c_object int + + val adt_decl : Cil_types.logic_type_info -> string + + + (**Be careful, this one is only used for debuging message! + Do not use for extraction *) + val pp_tau : Format.formatter -> tau -> unit + + (** {2 Terms} *) + + val e_true : boolean + val e_false : boolean + + val e_float : float -> real + val e_icst : string -> integer + val e_rcst : string -> real + val e_int64 : int64 -> integer + + (** {2 Arithmetics} *) + + val e_ineg : integer -> integer + val e_rneg : real -> real + val e_iop : int_op -> integer -> integer -> integer + val e_rop : real_op -> real -> real -> real + val e_icmp : cmp_op -> integer -> integer -> boolean + val e_rcmp : cmp_op -> real -> real -> boolean + val p_icmp : cmp_op -> integer -> integer -> pred + val p_rcmp : cmp_op -> real -> real -> pred + + val e_bnot : integer -> integer + val e_band : integer -> integer -> integer + val e_bor : integer -> integer -> integer + val e_bxor : integer -> integer -> integer + val e_lshift : integer -> integer -> integer + val e_rshift : integer -> integer -> integer + + val integer_of_real : real -> integer + val real_of_integer : integer -> real + + (** {2 Booleans} *) + + val e_bool : boolean -> integer + val e_not : boolean -> boolean + val e_and : boolean -> boolean -> boolean + val e_or : boolean -> boolean -> boolean + + (** {2 Conditional} *) + + val e_cond : boolean -> 'a term -> 'a term -> 'a term + val p_cond : boolean -> pred -> pred -> pred + + (** {2 records field} *) + + val e_getfield: Cil_types.fieldinfo -> record -> abstract + val e_setfield: Cil_types.fieldinfo -> record -> abstract -> record + + + val e_access : array -> integer -> abstract + val e_update : array -> integer -> abstract -> array + + (** {2 Predicates} *) + + val p_true : pred + val p_false : pred + val p_bool : boolean -> pred + val p_and : pred -> pred -> pred + val p_or : pred -> pred -> pred + val p_xor : pred -> pred -> pred + val p_not : pred -> pred + val p_implies : pred -> pred -> pred + val p_iff : pred ->pred -> pred + val p_eq : 'a term -> 'a term -> pred + val p_neq : 'a term -> 'a term -> pred + val p_conj : pred list -> pred + val p_disj : pred list -> pred + val p_named : string -> pred -> pred + + (** {2 Utilities} *) + + val is_true : pred -> bool + val is_false : pred -> bool + val huge_term : int -> 'a term -> bool + val huge_pred : int -> pred -> bool + + (** {2 Variables} + + Pools are used to generate fresh free variables. Do not mix + non-closed terms from different pools. + ) + + type pool + + val pool : unit -> pool + val p_fresh : pool -> string -> kind -> var + val p_freshen : pool -> var -> var + + val var : var -> 'a term + val eq_var : var -> var -> bool + val name_of_var : var -> string + val basename_of_var : var -> string + val tau_of_var : var -> tau + val kind_of_var : var -> kind + + val term_has_var : var list -> 'a term -> bool ( any of vars ) + val pred_has_var : var list -> pred -> bool ( any of vars *) + + val term_calls : string -> 'a term -> bool + val pred_calls : string -> pred -> bool + + val term_closed : 'a term -> bool + val pred_closed : pred -> bool + val freevars : pred -> var list + + val p_forall : var list -> pred -> pred + val p_exists : var list -> pred -> pred + val p_subst : (var -> var option) -> var -> 'a term -> pred -> pred + val e_subst : (var -> var option) -> var -> 'a term -> 'b term -> 'b term + + (** Requires domain to be disjoint from co-domain ) + val e_rename : (var var) list -> 'a term -> 'a term + + (** Returns true when the two terms are syntactically equals *) + val equal_terms : 'a term -> 'a term -> bool + + (** {3 Alpha conversion} *) + + (** Maping from old var to new var *) + type alpha + (** Empty mapping *) + val empty_alpha : alpha + val fold_alpha : (var -> var -> 'a -> 'a) -> alpha -> 'a -> 'a + + (** [alpha', p' = p_more_alpha_cv alpha p] build p' from p by renaming + * all the variable v into v' according to the mapping alpha. + * Add new mappings for the variables that are not already mapped. ) + val p_more_alpha_cv : alpha -> pred -> alpha pred + + (** easier to use when doing a simple alpha conversion. + * @return the new predicate and the newly created variables. ) + val p_alpha_cv : pred -> var list pred + + + (** {2 Pretty printers} *) + + val pp_var : Format.formatter -> var -> unit + val pp_section : Format.formatter -> string -> unit + val pp_term : Format.formatter -> 'a term -> unit + val pp_pred : Format.formatter -> pred -> unit + val pp_decl : Format.formatter -> decl -> unit + val pp_goal : Format.formatter -> string -> pred -> unit + val pp_vkind : Format.formatter -> kind -> unit + + + (** {2 FOL Helpers} *) + + val e_app0 : string -> 'a term + val e_app1 : string -> 'a term -> 'b term + val e_app2 : string -> 'a term -> 'b term -> 'c term + val e_app3 : string -> 'a term -> 'b term -> 'c term -> 'd term + val e_app4 : + string -> 'a term -> 'b term -> 'c term -> 'd term -> 'e term + val e_app5 : + string -> 'a term -> 'b term -> 'c term -> 'd term -> 'e term -> + 'f term + + val p_app0 : string -> pred + val p_app1 : string -> 'a term -> pred + val p_app2 : string -> 'a term -> 'b term -> pred + val p_app3 : string -> 'a term -> 'b term -> 'c term -> pred + val p_app4 : string -> + 'a term -> 'b term -> 'c term -> 'd term -> pred + val p_app5 : string -> + 'a term -> 'b term -> 'c term -> 'd term -> 'e term -> pred + + val dummy : unit -> pred + + val i_zero : integer + val r_zero : real + val i_one : integer + val i_add : integer -> integer -> integer + val i_mult : integer -> integer -> integer + val i_sub : integer -> integer -> integer + + + (** {2 Integer Logic Cast} *) + + val guard : Ctypes.c_int -> integer -> pred + val modulo : Ctypes.c_int -> integer -> integer + val i_convert: Ctypes.c_int -> Ctypes.c_int -> integer -> integer + + (**{2 Fol data } ) + type interval = { + inf : integer option ; + sup : integer option ; + } + + type 'a assigned = + | Aloc of c_object 'a + | Arange of c_object * 'a * interval + + type havoc = + | Fresh of var + | Update of var * ((var * var) list -> abstract) + + val pp_interval : Format.formatter -> interval -> unit + + (** {2 Sub-arrays} *) + + val set_range_index : array -> interval -> array + + (** {2 Set and Range as first Class Value} *) + + val empty : set + (**[empty()] returns the polymorphic empty set. *) + + val singleton : abstract -> set + (** [singleton a] returns the singleton set containning [a]. *) + + val union : set -> set -> set + (** [union s0 s1] returns the union set of [s0] and [s1]. *) + + val unions : set list -> set + + val inter : set -> set -> set + (**[inter s0 s1] returns the intersection set of [s0] and [s1]. *) + + val remove : set -> set -> set + (** [remove s0 s1] returns a set [s'] such as \{b in s' | b in s0 + and !(b in s1) \}.*) + + val set_of_list : abstract list -> set + + val add_set : set -> set -> set + + val mult_set : set -> set -> set + + val neg_set : set -> set + + val interval : interval -> set + (** [range l h] returns the integer set [s] such as \{ i in s | l <= + i <= h \}. *) + (** {2 Formats} *) + + (** {2 Record as First Class Value}*) + + val acc_field : + record -> Cil_types.fieldinfo -> abstract + (** Takes a record term of type (tau_of F.fcomp) and + returns the term of type (tau_of F) for its field 'F' *) + + val upd_field : + record -> Cil_types.fieldinfo -> abstract -> record + (** Takes a record term of type (tau_of F.fcomp) and + a new term of type (tau_of F) for its field 'F' + and return the updated record. *) + + (** {2 Array as first Class Value} *) + + val acc_index : array -> integer -> abstract + (** Takes term of type ['a farray] and returns the ['a] at index [i]. *) + + val upd_index : array -> integer -> abstract -> array + + + + (** {2 Buitin Indexd Declaration } *) + module type Indexed = + sig + include Registry + val get_ind : t -> integer + val has_ind : t -> pred -> bool + end + + module Dindex (I : Identifiable): + sig include Indexed with type t = I.t end + + module Findex : Indexed with type t = fieldinfo + module Xindex : Indexed with type t = varinfo + module Aindex : Indexed with type t = varinfo + module Tindex : Indexed with type t = compinfo + module LTindex : Indexed with type t = logic_type + +end + + +module type Logic = +sig + module F: S + + (** {2 Constrained Terms Construction} ) + type context + type bindings + + val closed : bindings + val close : bindings -> F.pred -> F.pred + + val push : string -> F.pool -> bindings -> context + val pop : string -> context -> bindings + val kill: string -> context -> unit + val flush : string -> context -> F.pred -> F.pred ( pop and close *) + + val term_such_that : tau -> ('a F.term -> F.pred) -> 'a F.term + + val forall : F.var list -> F.pred -> F.pred + val exists : F.var list -> F.pred -> F.pred + val subst : F.var -> 'a F.term -> F.pred -> F.pred + val fresh : string -> kind -> F.var + val alpha : F.var -> F.var option + val pool : unit -> F.pool + val vkind_of_var : F.var -> kind + val has_context_vars : F.var list -> F.pred -> bool + val has_type : F.abstract -> logic_type -> F.pred + val is_comp : Cil_types.compinfo -> F.abstract -> F.pred + val is_array: Ctypes.arrayinfo -> F.abstract -> F.pred + + (** {2 Generalized substitutions} ) + + + val apply : (F.var F.var) list -> 'a F.term -> 'a F.term + + val havoc_static : F.havoc list -> F.pred -> F.pred + val havoc_inductive : F.havoc list -> F.pred -> F.pred + +end + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/funvar_mem.ml frama-c-20111001+nitrogen+dfsg/src/wp/funvar_mem.ml --- frama-c-20110201+carbon+dfsg/src/wp/funvar_mem.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/funvar_mem.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,1000 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + + + +(* -------------------------------------------------------------------------- ) +( --- Functional Variable Memory Model Functor --- ) +( -------------------------------------------------------------------------- ) + +module WpLog = Wp_parameters +open Cil_types +open Cil_datatype +open Formula +open Ctypes +open Clabels + + +let debug = WpLog.debug ~dkey:"funvar" +let oracle = WpLog.debug ~dkey:"var_kind" + +module type Criteria = +sig + val isHoare : bool +end + + +module Create + (Crit:Criteria) + (M:Mwp.S) + = +struct + ( ------------------------------------------------------------------------ ) + ( --- Helper to move --- ) + ( ------------------------------------------------------------------------ ) + + ( [make_array ty] builts the cil type of an array of element of type [ty]) + let make_array ty = + debug "[make_array] %a" !Ast_printer.d_type ty; + TArray(ty,None,{scache=Cil_types.Not_Computed},[]) + + ([array_of typ] transforms a pointer type [typ] into an cil array type, + recursivly) + let rec array_of typ = + debug "[object_array_of] %a" !Ast_printer.d_type typ; + match Cil.unrollType typ with + | TPtr(typ,_) -> + begin + match Cil.unrollType typ with + | TVoid _ -> make_array (TInt (IChar,[])) + | t -> make_array (array_of t) + end + | _ -> typ + + +( [pointed_of_arity n typ] makes the cil type : [^n typ]) + let rec pointed_of_arity n typ = + debug "[pointed_of_arity] %a,%d" !Ast_printer.d_type typ n ; + if n > 0 + then pointed_of_arity (pred n) (Cil.typeOf_pointed typ) + else typ + + +([brackets_and_stars_typ typ], first computes the stars number of typ [n] and + the inner type [t] if typ = ^n t returns (n,t). Secondly, + computes the number of brackets in [t] [m]. + Finally returns the number of stars and the number of brackets [(n,m)].) + let brackets_and_stars_typ typ = + let rec stars_and_elt typ = + match Cil.unrollType typ with + | TPtr (typ,_) -> + let (n,t) = stars_and_elt (Cil.unrollType typ) in + (n+1),t + | TInt(_,_) | TFloat(_,_) | TFun _ | TEnum (_,_) | TComp (_,_,_) + | TArray (_,_,_,_) + | TBuiltin_va_list _ | TVoid _ | TNamed _ as t-> (0,t) + in + let (n,t) = stars_and_elt typ in (n,Variables_analysis.brackets_typ t) + +( the same in logic type) + let brackets_and_stars_lv_typ = function + | Ctype t -> brackets_and_stars_typ t | _ -> 0,0 + + + +( Path ) + module Lookup = + struct + + module F = M.F + + ( In a first intention, a path can be view as a pair + of a root and a list of offset use to describe an l-value.) + + ( offset of path) + type poffset = + | Ofield of fieldinfo ( a field) + | Oindex of F.integer Ctypes.c_object (an index and its type) + + (root of a path) + type root = + | Cvar of varinfo (a C variable ) + | Lvar of logic_var (* a purely logic variable (ie.lv_origin = None)) + + ( Definition of a path) + + ( NB : the field p_cvar only occurs if the root is a purely logic by + reference parameter when its inner model location it is required + for the translation of the predicate or function body. + Then and additional formal parameters has to been created. + This creation is global to a frame of the translation, then the + fol-variable has to been created in translate_prop and carry + to the memory model to be used in memory made formula. + ) + type path = { + p_root : root ; ( root ) + p_mem : M.mem ; ( in model memory model ) + p_arity : int ; ( arity such as define in by reference arity; + 0 otherwise) + p_off : poffset list ; ( the list of offset to form the current + l-value) + p_type : Ctypes.c_object option; + ( the type of the entire l-value represented + by this path) + p_cvar : F.var option ; ( the fol-variable represented the address + of the root.) + } + + ( Some smart constructors and helper to manage root and path. ) + + ( Pretty-printers ) + let pp_root fmt = function + | Cvar x -> !Ast_printer.d_var fmt x + | Lvar lv -> !Ast_printer.d_logic_var fmt lv + + let pp_path fmt p = + Format.fprintf fmt "PATH:%a of %d" + pp_root p.p_root (List.length p.p_off) + + ( [object_of_root r] returns the c_object of a root [r].) + let object_of_root = function + Cvar x -> Some (object_of x.vtype) + | Lvar lv -> + begin + match lv.lv_type with + | Ctype t -> Some (object_of t) + | _ -> None + end + + ( [object_array_of_root r] transforms the type of the root[r] + into an array type,c_object, if it was a pointer type. ) + let object_array_of_root = function + Cvar x -> Some (object_of (array_of x.vtype)) + | Lvar lv-> + begin + match lv.lv_type with + | Ctype t -> Some (object_of (array_of t)) + | _ -> None + end + + ([object_of_n_pointed n typ] makes the c_object type of a [n]-ary pointer + on inner type [typ] : [^n typ]) + let rec object_of_n_pointed n typ = + if n=0 then typ else + match typ with + | C_pointer typ -> object_of_n_pointed (pred n) (object_of typ) + | t -> WpLog.fatal + "[object_of_n_pointed] calls with mismatched arguments :%d and %a" + n pp_object t + + + let object_of_pointed_opt = function + | None -> None + | Some ty -> Some (Ctypes.object_of_pointed ty) + + let object_of_n_pointed_opt n = function + | None -> None + | Some ty -> Some (object_of_n_pointed n ty) + + + + + (* [pointed_of_path p] makes the deferenced path of [p].) + let pointed_of_path p = + debug "[pointed_of_path] %a" pp_path p; + { p with p_type = object_of_pointed_opt p.p_type } + + ( [pointed_of_n_path n p] makes the [n] time deferenced path of [p].) + let pointed_of_n_path n p = + debug "[pointed_of_n_path] %d %a" n pp_path p; + { p with p_type = object_of_n_pointed_opt n p.p_type } + + ( [sizeof_poffset off] returns de C sizeof of an offset.) + let sizeof_poffset = function + | Ofield fd -> F.e_int + (Int64.to_int (Ctypes.sizeof_object (object_of fd.ftype))) + | Oindex (i,o) -> + let typeof_obj = F.e_int64 (Ctypes.sizeof_object o) + in + F.e_iop Formula.Imul i typeof_obj + + ( [sizeof_path offs] returns the C sizeof of an offsets list.) + let sizeof_path offs = + List.fold_left + (fun acc i -> F.e_iop Iadd acc (sizeof_poffset i)) F.i_zero offs + + ( [access_poffset p off] makes the l-value from the term [p] and + the offset [off] : [p.f] or [p[i]] . ) + let access_poffset p = function + | Ofield f -> F.acc_field (F.unwrap p) f + | Oindex (i,_) -> F.acc_index (F.unwrap p) i + + ( [access t offs] makes the l-value from [t] with the offset list [offs]) + let access t offs = List.fold_left access_poffset t offs + + ( [mcvar m r opt_cv] according to the root [r] calls the approriate + function of the inner memory model to translate the root [r] in + the memory state [m]. + If [r] is a C variable then [cvar] else [lvar ]) + let mcvar m r opt_cv= + debug "[mcvar] of %a" pp_root r; + match r with + | Cvar x -> + debug "[mcvar] case of mem"; M.cvar m x + | Lvar lv -> + debug "[mcvar] case of logic %a" !Ast_printer.d_logic_var lv; + let ty = + match lv.lv_type with + | Ctype ty -> ty + | ty -> Wp_parameters.fatal + "[mcvar] c type of a pure logic type %a" + !Ast_printer.d_logic_type ty + in + let obj = Ctypes.object_of ty in + match opt_cv with + | None -> ( can't happen) + debug "[mcvar] case of none associated cvar"; + let tau = Formula.Pointer (M.tau_of_loc) in + debug "[mcvar] called fresh"; + let x = M.L.fresh lv.lv_name (Formula.Model tau) in + debug "[mcvar] binds %a to %a" + !Ast_printer.d_logic_var lv F.pp_var x ; + M.loc_of_term obj (F.var x) + | Some cx -> + debug "[mcvar] case of associated c varaible :%a" F.pp_var cx ; + M.loc_of_term obj (F.var cx) + + ( [mloc_of_path p] computes the location of the inner memory model + from the path [p].) + let mloc_of_path p = + debug "[mloc_of_path] %a" pp_path p; + List.fold_left + (fun loc offset -> + match offset with + | Ofield f -> M.field loc f + | Oindex(k,te) -> M.index loc te k + ) (mcvar p.p_mem p.p_root p.p_cvar) p.p_off + + end + + module Model = + struct + + open Lookup + + module F = M.F + module A = M.A + module R = M.R + + type loc = + Path of path (Functional Variable) + | PRef of path (Pointer Reference effective Argument) + | ARef of path (Array Reference effective Argument) + | PRpar of path int (Pointer by Reference Formal path and arity) + | ARpar of path * int (Array by Reference Formal path and arity) + | Mloc of M.loc (* Memory Location ) + + ( Pretty-printers ) + let pp_ref r fmt p opt_arity= + match opt_arity with + | None -> + Format.fprintf fmt "%s :%a of %d" r pp_root p.p_root + (List.length p.p_off) + | Some ari -> + Format.fprintf fmt "%s :(%a,%d) of %d" + r pp_root p.p_root ari (List.length p.p_off) + + let pp_loc fmt = function + | Mloc l -> M.pp_loc fmt l + | Path p -> pp_path fmt p + | PRef p -> pp_ref "Ptr REF" fmt p None + | PRpar (p,n) -> pp_ref "Ptr REF PARAM" fmt p (Some n) + | ARef p -> pp_ref "Array REF" fmt p None + | ARpar (p,n) -> pp_ref "Array REF PARAM" fmt p (Some n) + + let cast_loc_to_int ty l ty2 = + match l with + | Mloc l -> M.cast_loc_to_int ty l ty2 + | Path p | PRef p | PRpar (p,_) | ARef p | ARpar (p,_) -> + M.cast_loc_to_int ty (Lookup.mloc_of_path p) ty2 + + + let cast_int_to_loc ty i ty2 = Mloc (M.cast_int_to_loc ty i ty2) + + ([mloc_of_loc l] returns the location of the inner memory model + corresponding to the location [l].) + let mloc_of_loc = function + | Path p | PRef p | PRpar (p,_) | ARef p | ARpar (p,_) -> + Lookup.mloc_of_path p + | Mloc loc -> + debug "[mloc_of_loc] already a loc %a" M.pp_loc loc ; loc + + + let loc_of_term o t = Mloc (M.loc_of_term o t) + let term_of_loc l = M.term_of_loc (mloc_of_loc l) + + let null = Mloc M.null + let is_null l = M.is_null (mloc_of_loc l) + + + let root_equal a b = + match a,b with + | Cvar x, Cvar y -> Varinfo.equal x y + | Lvar l, Lvar p -> Logic_var.equal l p + | _,_ -> false + + let op_loc mop pop l1 l2= + match l1,l2 with + | Mloc l1 , Mloc l2 -> mop l1 l2 + | Path xp, Path yq | PRef xp, PRef yq | ARef xp,ARef yq + when root_equal xp.p_root yq.p_root -> + pop (sizeof_path xp.p_off) (sizeof_path yq.p_off) + | ARpar (xp,xn),ARpar (yq,ym) + | PRpar (xp,xn), PRpar(yq,ym) + when root_equal xp.p_root yq.p_root && xn = ym -> + pop (sizeof_path xp.p_off) (sizeof_path yq.p_off) + | l1,l2 -> mop (mloc_of_loc l1) (mloc_of_loc l2) + + let minus_loc = op_loc M.minus_loc (F.e_iop Isub) + let lt_loc = op_loc M.lt_loc (F.p_icmp Clt) + let le_loc = op_loc M.le_loc (F.p_icmp Cleq) + let le_loc_bool = op_loc M.le_loc_bool (F.e_icmp Cleq) + let lt_loc_bool = op_loc M.lt_loc_bool (F.e_icmp Clt) + let equal_loc_bool = op_loc M.equal_loc_bool (F.e_icmp Ceq) + let equal_loc = op_loc M.equal_loc (F.p_icmp Ceq) + let tau_of_loc = M.tau_of_loc + + + end + + open Model + open Lookup + + include Datalib.Cvalues(Model) + + module L = M.L + + type decl = M.F.decl + + ( ------------------------------------------------------------------------ ) + ( --- Values Coersion --- ) + ( ------------------------------------------------------------------------ ) + + + ([value_of_mvalue v] returns the value corresponding to value [v] + of the inner memory model) + let value_of_mvalue = function + | M.V_int (i,t) -> V_int (i,t) + | M.V_float (f,t) -> V_float (f,t) + | M.V_array (a,t) -> V_array(a,t) + | M.V_record (c,t) -> V_record (c,t) + | M.V_union (c,t) -> V_union (c,t) + | M.V_pointer (te,l) -> V_pointer (te,Mloc l) + + ([mvalue_of_value v] returns the value of the inner memory model + correspondig to the value [v]) + let mvalue_of_value = function + | V_int (i,t) -> M.V_int (i,t) + | V_float (f,t) -> M.V_float (f,t) + | V_array (a,t) -> M.V_array(a,t) + | V_record (c,t) -> M.V_record (c,t) + | V_union (c,t) -> M.V_union (c,t) + | V_pointer (te,Mloc l) -> M.V_pointer (te, l) + | V_pointer (_,Path _) + | V_pointer (_,PRef _ ) + | V_pointer (_,PRpar _) + | V_pointer (_,ARef _ ) + | V_pointer (_,ARpar _) -> + WpLog.fatal "[mvalue_of_value] of logical pointer" + + + + + ( ------------------------------------------------------------------------ ) + ( --- Env and Memory --- ) + ( ------------------------------------------------------------------------ ) + + module Xmap = Cil_datatype.Varinfo.Map + + ( translation information associated to a C variable.) + type var_info = + { v_var : F.var ; ( the fol-variable associated) + v_arity : int ; ( the arity as define for by reference) + v_is_array : bool ; ( true if it is an array reference) + v_type : Ctypes.c_object; ( the C_object type of the variable.) + + } + + ( C-variables translation environment) + type vars = var_info Xmap.t + + module Lmap = Cil_datatype.Logic_var.Map + + ( kind of a by-reference formal of userdef predicate) + type formal = + Fpref of int ( pointer by reference formal of arity [n] ) + | Faref of int ( array by reference formal of ... .) + + ( translation information associated to a by reference formal + of a user-definition) + type byrefparam = { + bref_var : F.var ; ( the fol-variable associated) + bref_formal : formal ; ( the kind of the by-reference formal + of user-definition ) + } + + ( The heap is compounded by 3 elements in the funvar memory model: + 1) [mem] which is the C inner memory model ; + 2) [vars] which is the environment of translation of the optimized + variable. + 3) [formals] which is the environment oftranslation of the by-reference + formal of user-definition.) + type mem = { + mem : M.mem ; + mutable vars : vars ; + mutable formals : byrefparam Lmap.t ; + } + + let mem () = { mem = M.mem () ; vars = Xmap.empty ; formals = Lmap.empty} + + + ( ------------------------------------------------------------------------ ) + ( --- Locations --- ) + ( ------------------------------------------------------------------------ ) + +( Globals mamagment ) + let global_scope _ p = p + let global _ = () + + ( Logic Parameters translation ) + let get_logic_funvar mem arity lv ap = + let s = "[get_logic_funvar]" in + try + let x = (Lmap.find lv mem.formals).bref_var in + debug "%s %a already recorded" s !Ast_printer.d_logic_var lv; x + with Not_found -> + debug "%s %a not yet recorded" s !Ast_printer.d_logic_var lv; + let t = match lv.lv_type with + | Ctype t -> t + | t -> WpLog.fatal "%s c type of pure logic type %a" + s !Ast_printer.d_logic_type t + in + let typ_logicvar = if ap then array_of t else pointed_of_arity arity t in + let obj_logicvar = Ctypes.object_of typ_logicvar in + let tau_logicvar = tau_of_object obj_logicvar in + let var = L.fresh lv.lv_name (Acsl(tau_logicvar,Ctype typ_logicvar)) in + debug "%s records %a" s F.pp_var var ; + let brefparam = { + bref_var = var ; + bref_formal = + if ap then Faref arity else Fpref arity ; + } in + mem.formals <- Lmap.add lv brefparam mem.formals; var + + ( C variable translation ) + let get_c_funvar mem arity vinfo ap = + let s = "[get_funvar]" in + try let x = (Xmap.find vinfo mem.vars).v_var in + debug "%s %a as %a already recorded" s !Ast_printer.d_var vinfo F.pp_var x; + x + with Not_found -> + debug "%s %a not yet recorded" s !Ast_printer.d_var vinfo; + let t = vinfo.vtype in + let typ_logicvar = if ap then array_of t else pointed_of_arity arity t in + let obj_logicvar = Ctypes.object_of typ_logicvar in + let tau_logicvar = tau_of_object obj_logicvar in + let var = L.fresh vinfo.vname (Acsl(tau_logicvar,Ctype typ_logicvar)) in + let v_info = + {v_var = var ; v_arity = arity ;v_is_array = ap ; v_type = obj_logicvar} + in + debug "%s (%a,%d,%b,%a)" s F.pp_var var arity ap pp_object obj_logicvar ; + mem.vars <- Xmap.add vinfo v_info mem.vars ; var + +( Variables translation) + let get_funvar mem arity root ap = + match root with + | Cvar x -> get_c_funvar mem arity x ap + | Lvar lv -> get_logic_funvar mem arity lv ap + +( [mk_path r m ] makes a path of root [r], + with memory [m], arity [0] and type of value. Used for all kind of + variable with path excepted by-reference parameter without C variable.) + let mk_path r m = + { p_root= r ; p_mem = m ; p_off=[] ; + p_arity=0 ; p_type=object_of_root r ; p_cvar = None ; } + + ( [mk_pref r m n opt_cv] makes the path of a pointer by-reference parameter + with root (r] memory [m], arity [n] and p_cvar [opt_cv].) + let mk_pref r m n opt_cv = + { p_root= r; p_mem = m ; p_off=[] ; p_arity=n ; + p_type=object_of_root r ; p_cvar = opt_cv ;} + + ( [mk_aref r m n opt_cv] makes the path of an array by-reference parameter + with root [r] memory [m], arity [n] and p_cvar [opt_cv].) + let mk_aref r m n opt_cv = + {p_root= r ; p_mem = m; p_off=[] ; p_arity=n ; + p_type=object_array_of_root r ; p_cvar = opt_cv;} + + let cvar m vi = + let r = Cvar vi in + match Variables_analysis.dispatch_cvar vi with + | Variables_analysis.Fvar -> + oracle + "%a is a funvar @." !Ast_printer.d_var vi ; + Path (mk_path r m.mem) + | Variables_analysis.Cvar when Crit.isHoare -> + oracle + "%a is a funvar @." !Ast_printer.d_var vi ; + Path (mk_path r m.mem) + | Variables_analysis.Cvar -> + oracle + "%a is a memvar @." !Ast_printer.d_var vi ; + Mloc (M.cvar m.mem vi) + | Variables_analysis.ARarg -> + oracle + "%a is a array refvar @." !Ast_printer.d_var vi; + if vi.vglob then M.global vi; + ARef (mk_path r m.mem) + | Variables_analysis.PRarg -> + oracle + "%a is a ptr refvar @." !Ast_printer.d_var vi ; + PRef (mk_path r m.mem) + | Variables_analysis.PRpar n -> + oracle + "%a is a ptr ref param of arity %d @." !Ast_printer.d_var vi n; + PRpar (mk_pref r m.mem n None, n) + | Variables_analysis.ARpar n -> + oracle + "%a is a array ref param of arity %d @." !Ast_printer.d_var vi n; + let (n0,_) = brackets_and_stars_typ vi.vtype in + if vi.vglob then global vi; + ARpar (mk_aref r m.mem n None, n0) + + + let lvar m lv x= + let r = Lvar lv in + match Variables_analysis.dispatch_lvar lv with + | Variables_analysis.Fvar -> + oracle + "%a is a funvar @." !Ast_printer.d_logic_var lv ; + Path (mk_path r m.mem) + | Variables_analysis.Cvar when Crit.isHoare -> + oracle + "%a is a funvar @." !Ast_printer.d_logic_var lv ; + Path (mk_path r m.mem) + | Variables_analysis.Cvar -> + oracle + "%a is a memvar @." !Ast_printer.d_logic_var lv ; + Mloc (M.lvar m.mem lv x) + | Variables_analysis.ARarg -> + oracle + "%a is a array refvar @." !Ast_printer.d_logic_var lv; + ARef (mk_path r m.mem) + | Variables_analysis.PRarg -> + oracle + "%a is a ptr refvar @." !Ast_printer.d_logic_var lv ; + PRef (mk_path r m.mem) + | Variables_analysis.PRpar n -> + oracle + "%a is a ptr ref param of arity %d @." + !Ast_printer.d_logic_var lv n; + PRpar (mk_pref r m.mem n (Some x), n) + | Variables_analysis.ARpar n -> + oracle + "%a is a array ref param of arity %d @." + !Ast_printer.d_logic_var lv n; + let (n0,_) = brackets_and_stars_lv_typ lv.lv_type in + ARpar (mk_aref r m.mem n (Some x), n0) + + let inner_loc loc = M.term_of_loc (mloc_of_loc loc) + + ( [add_index p i ty] makes the path of the l-value of the path (p] and + the index [i] with type [ty].) + let add_index p i ty = + { p with + p_off = p.p_off @ [Lookup.Oindex (i,ty)] ; + p_type = Some ty } + + let shift l ty i = + match l with + | Mloc l -> Mloc (M.shift l ty i) + | PRef p -> Path (add_index p i ty) + | ARef p -> ARef (add_index p i ty) + | PRpar (p,0) | Path p -> + let loc = Lookup.mloc_of_path p in + Mloc (M.shift loc ty i) + | PRpar (p,n) -> PRpar (add_index p i ty,n) + | ARpar (p,n) -> ARpar (add_index p i ty,n) + + let index l ty i = + match l with + | Mloc l -> Mloc (M.index l ty i) + | Path p -> Path (add_index p i ty) + | PRef p -> PRef (add_index p i ty) + | ARef p -> ARef (add_index p i ty) + | PRpar(p,n)-> PRpar (add_index p i ty,n) + | ARpar (p,n) -> ARpar (add_index p i ty,n) + + ([add_field p finfo] makes the path of the l-value of the path [p] + and the field access to [finfo].) + let add_field p finfo = + { p with + p_off = p.p_off@[Lookup.Ofield finfo] ; + p_type = Some (object_of finfo.ftype) } + + let field l finfo = + match l with + | Mloc l -> Mloc (M.field l finfo) + | Path p -> Path(add_field p finfo) + | PRef p -> PRef(add_field p finfo) + | PRpar (p,n) -> PRpar(add_field p finfo,n) + | ARef p -> ARef(add_field p finfo) + | ARpar (p,n) -> ARpar(add_field p finfo,n) + + let startof l ty = + match l with + | ARef p -> debug "[startof] %a" pp_path p ; ARef p + | ARpar (p,n) -> ARpar(p,n) + | _ -> Mloc (M.startof (mloc_of_loc l) ty) + + ( ------------------------------------------------------------------------ ) + ( --- Pointers --- ) + ( ------------------------------------------------------------------------ ) + + let cast_loc_to_loc t1 t2 = function + | Mloc l -> Mloc (M.cast_loc_to_loc t1 t2 l) + | ARef p -> debug "[cast_loc_to_loc %a from %a to %a]" + pp_path p !Ast_printer.d_type t1 !Ast_printer.d_type t2; + index (ARef p) (object_of t2) F.i_zero + | Path _ | PRef _ | PRpar _ | ARpar _ -> + WpLog.not_yet_implemented + "Cast from %a to %a of over a logical-variable (try -wp-no-logicvar)" + !Ast_printer.d_type t1 !Ast_printer.d_type t2 + + ( ------------------------------------------------------------------------ ) + ( --- Load --- ) + ( ------------------------------------------------------------------------ ) + ( [fun_load m p ap] returns the load value of the path [p] in the + memory state [m] according to the test of being an + array by-reference [ap].) + let fun_load m p ap = + let xv = F.var(get_funvar m p.p_arity p.p_root ap) in + match p.p_off, p.p_type with + | [],Some ty -> value_of_logic ty xv + | off,Some ty -> + let vload = Lookup.access xv off in + value_of_logic ty vload + | _ , None -> Wp_parameters.fatal + "[fun_load] offset none null for pure logic type" + + let load m cv l = + match l with + | Mloc l -> value_of_mvalue (M.load m.mem cv l) + | PRef p | Path p -> fun_load m p false + | ARef p -> fun_load m p true + | PRpar (p,0) -> fun_load m p false + | ARpar (p,0) -> fun_load m p true + | ARpar (p,n) -> V_pointer(cv,ARpar(pointed_of_path p,n-1)) + | PRpar (p,n) -> V_pointer(cv,PRpar (pointed_of_path p,n-1)) + + + ( ------------------------------------------------------------------------ ) + ( --- Zones --- ) + ( ------------------------------------------------------------------------ ) + + let massigned = function + | F.Aloc(te,l) -> + debug "massigned case loc : %a" pp_loc l; + F.Aloc(te,mloc_of_loc l) + | F.Arange(te,l,rg) -> + debug "massigned case range : %a becomes %a" + pp_loc l M.pp_loc (mloc_of_loc l); + F.Arange(te,mloc_of_loc l,rg) + + type m_dzone = M.m_dzone + type dzone = M.dzone + let tau_of_dzone = M.tau_of_dzone + + let dzone_assigned m z = M.dzone_assigned m.mem (massigned z) + let dzone_subset = M.dzone_subset + let dzone_union = M.dzone_union + let dzone_empty = M.dzone_empty + + let effect_supported = M.effect_supported + + ( ------------------------------------------------------------------------ ) + ( --- Pointers Logic Properties --- ) + ( ------------------------------------------------------------------------ ) + + let base_address m l = Mloc (M.base_address m.mem (mloc_of_loc l)) + let block_length m l = M.block_length m.mem (mloc_of_loc l) + let valid m z = M.valid m.mem (massigned z) + let separated m z1 z2 = M.separated m.mem (massigned z1) (massigned z2) + + ( ------------------------------------------------------------------------ ) + ( --- By Reference Parameters of User-definitions --- ) + ( ------------------------------------------------------------------------ ) + + let pp_formal_simple fmt = function + | Fpref n -> Format.fprintf fmt "Fpref %d" n + | Faref n -> Format.fprintf fmt "Faref %d" n + + let pp_formal (fmt:Format.formatter) (formal,lv) = + match formal with + | Fpref n -> + Format.fprintf fmt "%s%s" (String.make n '') lv.lv_name + | Faref n -> + Format.fprintf fmt "%s%t" + lv.lv_name + (fun fmt -> for i=1 to n do Format.pp_print_string fmt "[]" done) + + + let userdef_ref_has_cvar (lv : logic_var) : bool = + Variables_analysis.is_user_formal_in_builtin lv + + (* [userdef_is_ref_param lv] tests if a pure logic variable [lv] is + a by reference formal parameter of a user definition. ) + let userdef_is_ref_param lv = + match Variables_analysis.dispatch_lvar lv with + | Variables_analysis.Fvar | Variables_analysis.Cvar + | Variables_analysis.ARarg | Variables_analysis.PRarg -> false + | Variables_analysis.PRpar _ | Variables_analysis.ARpar _ -> true + + ( [userdef_ref_signature mem] returns the part of the signature + of a user definition corresponding to its by-reference parameters.) + let userdef_ref_signature mem : ( F.var logic_var * formal ) list = + let s = "[userdef_ref_signature]" in + debug "%s" s; + Lmap.fold + (fun lv param signature -> + debug "%s of %a" s !Ast_printer.d_logic_var lv ; + (param.bref_var , lv , param.bref_formal) :: signature + ) mem.formals [] + + + let userdef_ref_apply m fml loc = + debug "[userdef_ref_apply] calls with formal %a and loc %a" + pp_formal_simple fml pp_loc loc ; + begin + match fml, loc with + | Fpref 1, PRef p -> fun_load m p false + | Faref 1, ARef p -> fun_load m p true + | Fpref k, PRpar (p,r) -> + let n = k-r-1 in + if n = 0 then fun_load m p false + else + ( + match p.p_type with + | None -> Wp_parameters.fatal + "[userdef_ref_apply] pure type" + | Some ty -> + let obj = object_of_n_pointed n ty in + V_pointer(obj, PRpar(pointed_of_n_path n p,n))) + | Faref k, ARpar(p,r) -> + let n = k-r-1 in + if n = 0 then fun_load m p true + else + ( + match p.p_type with + | None -> Wp_parameters.fatal + "[userdef_ref_apply] pure type" + | Some ty -> + let obj = object_of_n_pointed n ty in + V_pointer(obj, ARpar(pointed_of_n_path n p,n))) + | f , l -> WpLog.fatal + "[userdef_ref_apply] calls with fml:%a and loc:%a" + pp_formal_simple f pp_loc l + end + + (* ------------------------------------------------------------------------ ) + ( --- Functional Closure --- ) + ( ------------------------------------------------------------------------ ) + + type closure = + | Fclos of int bool * Cil_types.varinfo (* arity, isArray ) + | Mclos of M.closure + + let pp_closure fmt = function + | Mclos cl -> M.pp_closure fmt cl + | Fclos(k,ap,vinfo) -> + if ap then + ( array ) + Format.fprintf fmt "value of %s%t" + vinfo.vname ( C-original name ) + (fun fmt -> for i=1 to k do Format.pp_print_string fmt "[]" done) + else + ( ref. ) + Format.fprintf fmt "value of %s%s" + (String.make k '') vinfo.vname + + let userdef_mem_signature m = + Xmap.fold + (fun v vi fs -> (vi.v_var,Fclos(vi.v_arity,vi.v_is_array,v))::fs) + m.vars + (List.map (fun (y,c) -> y,Mclos c) (M.userdef_mem_signature m.mem)) + + let userdef_mem_apply m = function + | Fclos(k,ap,vinfo) -> F.var (get_c_funvar m k vinfo ap) + | Mclos mc -> M.userdef_mem_apply m.mem mc + + (* ------------------------------------------------------------------------ ) + ( --- Labels & Quantification --- ) + ( ------------------------------------------------------------------------ ) + + let update ~(at:mem) ~(here:mem) p = + Xmap.fold + (fun v vi p -> + let x_here = get_c_funvar here vi.v_arity v vi.v_is_array in + L.subst vi.v_var (F.var x_here) p) + at.vars + (M.update at.mem here.mem p) + + let quantify m p = + let xs = Xmap.fold (fun _ vi xs -> vi.v_var::xs) m.vars [] in + L.forall xs (M.quantify m.mem p) + + ( ------------------------------------------------------------------------ ) + ( --- Assignments --- ) + ( ------------------------------------------------------------------------ ) + + ([update_offset phi current offs] applies the l-value made + from the l-value [current] and the list of offset [offs] to the + hole-term [phi]. ) + let rec update_offset phi current offs = + match offs with + | [] -> phi current + | off::m -> + let v = Lookup.access_poffset current off in + let r = update_offset phi v m in + begin + match off with + | Lookup.Ofield f -> + F.wrap (F.upd_field (F.unwrap current) f r) + | Lookup.Oindex (i,_obj) -> + F.wrap (F.upd_index (F.unwrap current) i r) + end + + ( [store m p v ap wp] firts, stores in the memory state [m] + the value [v] to the path [p] according the by-reference array test [ap] + and returns the property [wp] in this new memory state.) + let store m p v ap wp = + let x = get_funvar m p.p_arity p.p_root ap in + let v' = update_offset (fun _ -> logic_of_value v) (F.var x) p.p_off in + L.subst x v' wp + + let subst_lval m obj loc v wp = + match loc with + | Mloc l -> M.subst_lval m.mem obj l (mvalue_of_value v) wp + | Path ph | PRef ph | PRpar (ph,_)| ARef ph -> + store m ph v false wp + | ARpar (ph,_) -> store m ph v true wp + + ( ------------------------------------------------------------------------ ) + ( --- Zone Havoc --- ) + ( ------------------------------------------------------------------------ ) + + let subst_havoc (m:mem) = function + + | F.Aloc(_,(Path p| PRef p | PRpar(p,_))) + when p.p_off=[] -> + let x = get_funvar m p.p_arity p.p_root false in + let v = L.fresh (F.basename_of_var x) (F.kind_of_var x) in + [F.Fresh v;F.Update(x,fun _ -> F.var v)] + | F.Aloc(_, (ARpar(p,_)| ARef p)) when p.p_off=[] -> + let x = get_funvar m p.p_arity p.p_root true in + let v = L.fresh (F.basename_of_var x) (F.kind_of_var x) in + [F.Fresh v;F.Update(x,fun _ -> F.var v)] + + | F.Aloc(_,(Path p| PRef p | PRpar(p,_))) -> + let x = get_funvar m p.p_arity p.p_root false in + let v = + match p.p_type with + | None -> Wp_parameters.fatal "[subst_havoc] pure logic var" + | Some ty -> + L.fresh "v" (Model (tau_of_object ty)) + in + let newterm (sigma : (F.var F.var) list ) : F.abstract = + F.wrap ( update_offset + (fun _ -> F.var v) + (L.apply sigma (F.var x)) p.p_off ) + in + [F.Fresh v;F.Update(x,newterm)] + + | F.Aloc(_, (ARpar(p,_)| ARef p)) -> + let x = get_funvar m p.p_arity p.p_root true in + let v = + match p.p_type with + | None -> Wp_parameters.fatal "[subst_havoc] of pure logic var" + | Some ty -> L.fresh "v" (Model (tau_of_object ty)) + in + let newterm (sigma : (F.var * F.var) list ) : F.abstract = + F.wrap ( update_offset + (fun _ -> F.var v) + (L.apply sigma (F.var x)) p.p_off ) + in + [F.Fresh v;F.Update(x,newterm)] + + | F.Arange(_,(Path p| PRef p | PRpar(p,_)),rg) -> + let x = get_funvar m p.p_arity p.p_root false in + let upd_range rg = fun array -> + F.wrap (F.set_range_index (F.unwrap array) rg) + in + let newterm (sigma :(F.var * F.var) list ) : F.abstract = + F.wrap (update_offset (upd_range rg) (L.apply sigma (F.var x)) + p.p_off) + in + [F.Update(x,newterm)] + + | F.Arange(_, (ARpar(p,_)| ARef p),rg) -> + let x = get_funvar m p.p_arity p.p_root true in + let upd_range rg = fun array -> + F.wrap (F.set_range_index (F.unwrap array) rg) + in + let newterm (sigma :(F.var * F.var) list ) : F.abstract = + F.wrap (update_offset (upd_range rg) (L.apply sigma (F.var x)) + p.p_off) + in + [F.Update(x,newterm)] + + | F.Aloc(te,Mloc l) -> + M.subst_havoc m.mem (F.Aloc(te,l)) + + | F.Arange(te,Mloc l,rg) -> + M.subst_havoc m.mem (F.Arange(te,l,rg)) + + let assigns_goal m1 reg m2 = + (* Not very usefull, since assigns_supported = false !! ) + let region = + List.map + (function + | F.Aloc(_,Path _) | F.Arange(_,Path _,_) + | F.Aloc(_,PRef _) | F.Arange(_,PRef _,_) + | F.Aloc(_,PRpar _) | F.Arange(_,PRpar _,_) + | F.Aloc(_,ARef _) | F.Arange(_,ARef _,_) + | F.Aloc(_,ARpar _) | F.Arange(_,ARpar _,_) -> + WpLog.fatal + "Proof of assigns-clause with hoare-region" + | F.Aloc(te,Mloc l) -> F.Aloc(te,l) + | F.Arange(te,Mloc l,rg) -> F.Arange(te,l,rg)) + reg + in + M.assigns_goal m1.mem region m2.mem + + let assigns_supported = false + + ( ------------------------------------------------------------------------ ) + ( --- Local Scope --- ) + ( ------------------------------------------------------------------------ ) + + let local_scope m lx b p = + let xs = List.filter Variables_analysis.is_to_scope lx in + M.local_scope m.mem xs b p + +end + + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/funvar_mem.mli frama-c-20111001+nitrogen+dfsg/src/wp/funvar_mem.mli --- frama-c-20110201+carbon+dfsg/src/wp/funvar_mem.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/funvar_mem.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,57 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Memory Model for functional variables. *) +(** Optimisation for variables which address is never taken. ) +( -------------------------------------------------------------------------- *) + +(** The interaction between M and funvar depends on criteria. + For instance, the Store model discharges the traitment of + functional variables to funvar and traits the variables + which addresses are taken. + For the Hoare model thing are different : + the traitment of functional variables is discharged to funvar. + A variable which address is taken has to be represented by + two locations : + 1) One for itself traits by funvar + 2) Another for its address traits by M. + Hence, to drive the set of variables manage by M (mem) of + funvar (fun), use the module Criteria. +*) + + + +(** Define the criteria of variables trait by funvar of by M ) +module type Criteria = +sig + val isHoare : bool +end + +module Create (Crit:Criteria)(M:Mwp.S) : Mwp.S with module F=M.F + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/hoare_mem.ml frama-c-20111001+nitrogen+dfsg/src/wp/hoare_mem.ml --- frama-c-20110201+carbon+dfsg/src/wp/hoare_mem.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/hoare_mem.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,425 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Memory Model for Hoare. ) +( -------------------------------------------------------------------------- ) + +( TODO, ZD : + A lot of the code of hoare model is identical to the code of store. + Mayby, we can try to share more (even some) ) + +open Cil_types +open Cil_datatype + +module Create + (F:Formula.S) + (A:Mint.S with module F = F) + (R:Mfloat.S with module F = F) + = +struct + type m_pointer + type pointer = m_pointer F.term + + type decl = F.decl + + let unsupported = Wp_error.unsupported + + type m_alloc = Formula.m_array + let t_alloc : Formula.tau = Formula.ADT("farray",[Formula.Integer]) + type alloc = m_alloc F.term + + let model_ptr = F.e_app2 "ptr" + let model_base = F.e_app1 "base" + let model_offset = F.e_app1 "offset" + let model_shift = F.e_app2 "shift" + + let model_range = F.e_app3 "range_ptr" + let model_rbase = F.e_app1 "rbase" + let model_roffset = F.e_app1 "roffset" + let model_range_of_ptr = F.e_app2 "range_of_ptr" + let model_range_of_ptr_range = F.e_app3 "range_of_ptr_range" + let model_separated = F.p_app2 "separated" + let model_valid = F.p_app2 "valid" + + + + let sizeof te = F.e_int64 (Ctypes.sizeof_object te) + let n_size n te = F.i_mult n (sizeof te) + let add_offset d te k = F.i_add d (n_size k te) + let cardinal a b = F.i_add F.i_one (F.i_sub b a) + + let offset_of_field f = + let rec acc sz l f = + match l with + | [] -> Wp_parameters.fatal "[offset_of_field] not found %s" f.fname + | fi::m -> + if Cil_datatype.Fieldinfo.equal f fi + then sz + else acc (F.i_add sz (sizeof (Ctypes.object_of fi.ftype))) m f + in + acc F.i_zero f.fcomp.cfields f + + module Model = struct + module F = F + module A = A + module R = R + + + + let tau_of_loc = Formula.ADT("pointer",[]) + + type loc = | Addr of F.integer F.integer | Ptr of pointer + + let ptr = function + | Addr(b,d) -> model_ptr b d + | Ptr p -> p + + let base = function + | Addr(b,_) -> b + | Ptr p -> model_base p + + let offset = function + | Addr(_,d) -> d + | Ptr p -> model_offset p + + let loc_of_term _ p = Ptr (F.unwrap p) + let term_of_loc loc = F.wrap (ptr loc) + + + let rec pp_loc fmt l = match l with + | Addr (x,i) -> Format.fprintf fmt "@@ptr(%a,%a)" + F.pp_term x F.pp_term i + | Ptr p -> Format.fprintf fmt "%a" F.pp_term p + + + let equal_loc_bool l1 l2 = + F.e_app2 "eq_ptr_bool" (ptr l1) (ptr l2) + let lt_loc_bool l1 l2 = + F.e_app2 "lt_ptr_bool" (ptr l1) (ptr l2) + let le_loc_bool l1 l2 = + F.e_app2 "le_ptr_bool" (ptr l1) (ptr l2) + let equal_loc l1 l2 = + F.p_app2 "eq_ptr" (ptr l1) (ptr l2) + let lt_loc l1 l2 = + F.p_app2 "lt_ptr" (ptr l1) (ptr l2) + let le_loc l1 l2 = + F.p_app2 "le_ptr" (ptr l1) (ptr l2) + let minus_loc l1 l2 = + F.e_app2 "minus_ptr" (ptr l1) (ptr l2) + + let null = Addr(F.i_zero,F.i_zero) + let is_null l = + F.e_app2 "addr_eq" (ptr l) (model_ptr F.i_zero F.i_zero) + + let cast_loc_to_int _tp _p _ti = unsupported "cast from pointer to int" + let cast_int_to_loc _ti _i _tp = unsupported "cast from int to pointer" + end + + let cast_loc_to_loc ty1 ty2 l = + if Ctypes.equal (Ctypes.object_of ty1)(Ctypes.object_of ty2) then l + else + unsupported "cast from pointer (%a) to pointer (%a)" + !Ast_printer.d_type ty1 !Ast_printer.d_type ty2 + + module V = Datalib.Cvalues(Model) + module L = Datalib.Create(V) + include V + open Model + + module Globals = F.DRegister + (struct + include F.Varinfo + + let declare x _ = + let pool = F.pool () in + let xa = F.p_fresh pool "ta" (Formula.Model t_alloc) in + let sx = sizeof (Ctypes.object_of x.vtype) in + let xk = F.Xindex.get_ind x in + let sa = F.e_access (F.var xa) xk in + let gta = F.p_app1 "global" (F.var xa) in + Formula.Axiom (F.p_forall [xa] + (F.p_implies gta (F.p_eq (F.unwrap sa) sx))) + + let section = Formula.S_Model_Prop + let prefix = "Alloc" + let basename x = x.vname + let clear () = () + let pp_descr fmt _x = + Format.fprintf fmt "Global allocation table" + end) + + + + let global v = Globals.define v + + let cvar _m vi = + if vi.vglob then global vi ; + Addr (F.Xindex.get_ind vi,F.i_zero ) + + + let inner_loc _ = Wp_parameters.fatal "[inner_loc] reserved to funvar" + + let lvar _m lv x = + let ty = + match lv.lv_type with + | Ctype ty -> ty + | ty -> Wp_parameters.fatal + "[lvar] c type of pure logic type %a" + !Ast_printer.d_logic_type ty + in + loc_of_term (Ctypes.object_of ty)(F.var x) + + let offset loc te n = + match loc with + | Model.Addr(b,d) -> Model.Addr(b,add_offset d te n) + | Model.Ptr p -> Model.Ptr (model_shift p (n_size n te )) + + let field l f = + if f.fcomp.cstruct then + let pos = offset_of_field f in + match l with + | Model.Addr(b,d) -> Model.Addr(b,(F.i_add d pos)) + | Model.Ptr p -> Model.Ptr (model_shift p pos) + else l + + + let shift = offset + let index = offset + let startof l _cv = l + + + + type mem = + { vars : F.var Varinfo.Hashtbl.t ; + x_alloc : F.var ; + alloc : alloc ; + } + + let mem () = + let x_t = L.fresh "ta" (Formula.Model t_alloc) in + { + vars = Varinfo.Hashtbl.create 10; + x_alloc = x_t ; + alloc = F.var x_t; + } + + (**********************************************************************************) + + ( Get the wp variable of the C variable. ) + let get_var m lv = + try Varinfo.Hashtbl.find m lv + with Not_found -> + let ty = lv.vtype in + let t = tau_of_object (Ctypes.object_of ty) in + let v = L.fresh lv.vname (Formula.Acsl(t,Ctype ty)) in + Varinfo.Hashtbl.add m lv v; v + + let load _m _cobj _loc = unsupported "undirect access" + + let base_address _ = function + | Model.Addr(b,_) -> Model.Addr(b,F.i_zero) + | Model.Ptr p -> Model.Ptr (model_ptr (model_base p) F.i_zero) + + let block_length mem l = F.unwrap (F.e_access mem.alloc (base l)) + + + ( --- WP Calculus ) + + let update ~(at:mem) ~(here:mem) p = + let dov vi v_l p = + let v_here = get_var here.vars vi in + L.subst v_l (F.var v_here) p + in + L.subst at.x_alloc here.alloc + (Varinfo.Hashtbl.fold dov at.vars p) + + let quantify m p = + let xs = Varinfo.Hashtbl.fold (fun _ v xs -> v::xs) m.vars [] in + L.forall (m.x_alloc::xs) p + + let subst_lval _env _t _loc _v_exp _p = unsupported "undirect access" + + let alloc ta v sz = F.e_update ta v sz + let free ta v = F.e_update ta v (F.wrap F.i_zero) + + let alloc_vars m xs p = + List.fold_left + (fun p x -> + let v_x = F.Xindex.get_ind x in + let sz_x = F.wrap (sizeof (Ctypes.object_of x.vtype)) in + L.subst m.x_alloc (alloc m.alloc v_x sz_x) p + ) p xs + + let free_vars m xs p = + List.fold_left + (fun p x -> + let v_x = F.Xindex.get_ind x in + L.subst m.x_alloc (free m.alloc v_x) p + ) p xs + + let notexists_vars m xs p = + List.fold_left + (fun p x -> + let v_x = F.Xindex.get_ind x in + let q = F.p_eq (F.unwrap(F.e_access m.alloc v_x)) F.i_zero in + F.p_implies q p + ) p xs + + + let global_scope m p = + if L.has_context_vars [m.x_alloc] p + then F.p_implies (F.p_app1 "global" m.alloc) p + else p + + + let local_scope m vars scope p = + match scope with + | Mcfg.SC_Function_frame -> p + | Mcfg.SC_Block_in | Mcfg.SC_Function_in -> + notexists_vars m vars (alloc_vars m vars p) + | Mcfg.SC_Block_out | Mcfg.SC_Function_out -> + free_vars m vars p + | Mcfg.SC_Global -> + if L.has_context_vars [m.x_alloc] p + then F.p_implies (F.p_app1 "global" m.alloc) p + else p + + ( ----------------------------------------------------------------------- ) + ( --- Setof Locations --- ) + ( ----------------------------------------------------------------------- ) + + let range_of_assignable = function + | F.Aloc(te,loc) -> + let size = sizeof te in + begin + match loc with + | Model.Addr(b,d) -> model_range b d size + | Model.Ptr p -> model_range_of_ptr p size + end + | F.Arange(te,loc,rg) -> + begin + match rg with + |{F.inf=None;F.sup=Some h} -> + let size = n_size (F.i_add h F.i_one) te in + (match loc with + | Model.Addr(b,d) -> model_range b d size + | Model.Ptr p -> model_range_of_ptr p size + ) + | {F.inf=Some l;F.sup=Some h} -> + let delta = n_size l te in + let size = n_size (cardinal l h) te in + (match loc with + | Model.Addr(b,d) -> + model_range b (F.i_add d delta) size + | Model.Ptr p -> + model_range_of_ptr (model_shift p delta) size + ) + | _ -> unsupported "infinite range for array" + + end + + let valid mem z = + let r = range_of_assignable z in model_valid mem.alloc r + + let separated _ z1 z2 = + let r1 = range_of_assignable z1 in + let r2 = range_of_assignable z2 in + model_separated r1 r2 + + + ( ----------------------------------------------------------------------- ) + ( --- Zone Assigns --- ) + ( ----------------------------------------------------------------------- ) + + type m_dzone + type dzone = m_dzone F.term + let tau_of_dzone = Formula.ADT("zone",[]) + + let dzone_assigned _ _ = + Wp_parameters.not_yet_implemented "zone representation in Hoare" + + let dzone_subset _z1 _z2 = + Wp_parameters.not_yet_implemented "zone subset in Hoare" + + let dzone_union _z1 _z2 = + Wp_parameters.not_yet_implemented "zone union in Hoare" + + let dzone_empty () = + Wp_parameters.not_yet_implemented "empty zone in Hoare" + + let effect_supported = false + + + ( ----------------------------------------------------------------------- ) + ( --- Normal Assigns --- ) + ( ----------------------------------------------------------------------- ) + + let assigns_goal _env _sloc _lto = unsupported "proof of assigns clauses" + + let assigns_supported = false + + ( ----------------------------------------------------------------------- ) + ( --- Havoc --- ) + ( ----------------------------------------------------------------------- ) + + let subst_havoc _ _ = + Wp_parameters.not_yet_implemented "subst_havoc of pointer" + + ( ----------------------------------------------------------------------- ) + ( --- User Predicate environment --- ) + ( ----------------------------------------------------------------------- ) + + type closure = Var of Cil_types.varinfo | Alloc + + let pp_closure fmt = function + | Var vinfo -> Format.fprintf fmt "value of %a" !Ast_printer.d_var vinfo + | Alloc -> Format.fprintf fmt "allocation table" + + let userdef_mem_signature m = + Varinfo.Hashtbl.fold + (fun varinfo fvar signature -> (fvar,Var varinfo)::signature) + m.vars [m.x_alloc,Alloc] + + let userdef_mem_apply mem = function + | Var varinfo -> F.var (get_var mem.vars varinfo) + | Alloc -> F.wrap mem.alloc + + ( ------------------------------------------------------------------------ ) + ( --- Functional Closure --- ) + ( ------------------------------------------------------------------------ ) + + type formal = unit + let pp_formal (_:Format.formatter) _ = () + let userdef_is_ref_param (_:logic_var) : bool = false + let userdef_ref_signature (_:mem) : ( F.var logic_var * formal ) list = [] + let userdef_ref_apply (_:mem) (_:formal) (_:loc) : value = + Wp_parameters.fatal "[userdef_ref_apply] of model Hoare" + let userdef_ref_has_cvar (_ : logic_var) : bool = false + +end + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/hoare_mem.mli frama-c-20111001+nitrogen+dfsg/src/wp/hoare_mem.mli --- frama-c-20110201+carbon+dfsg/src/wp/hoare_mem.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/hoare_mem.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,27 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( ) +() + +module Create + (F:Formula.S) + (A:Mint.S with module F = F) + (R:Mfloat.S with module F = F) + : Mwp.S with module F = F and module A = A and module R = R diff -Nru frama-c-20110201+carbon+dfsg/src/wp/kreal.ml frama-c-20111001+nitrogen+dfsg/src/wp/kreal.ml --- frama-c-20110201+carbon+dfsg/src/wp/kreal.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/kreal.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,103 @@ +() +( ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Coq Real Constants --- ) +( -------------------------------------------------------------------------- ) + +let error () = raise (Invalid_argument "invalid real constant") + +type sign = Positive | Negative +type state = Integral | Fraction | Exponent + +type env = { + mantiss : Buffer.t ; + exponent : Buffer.t ; + mutable sign : sign ; + mutable coma : int ; ( number of digits afer '.' *) + mutable state : state ; +} + +type token = + | Digit + | Plus + | Minus + | Exp + | Dot + +let token = function + | ('0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9') -> Digit + | '.' -> Dot + | '-' -> Minus + | '+' -> Plus + | 'e' | 'E' -> Exp + | _ -> error () + +let trail m = + let n = String.length m in + let rec first k = if k < n && m.[k] = '0' then first (succ k) else k in + let rec last k = if k >= 0 && m.[k] = '0' then last (pred k) else k in + let a = first 0 in + let b = last (n-1) in + if a <= b then Some(a , n-b-1) else None + +let convert r = + let e = { + mantiss = Buffer.create 64 ; sign = Positive ; + exponent = Buffer.create 64 ; + coma = 0 ; state = Integral ; + } in + String.iter + (fun c -> + let tk = token c in + match e.state , tk with + | _ , Dot -> e.state <- Fraction ; + | _ , Exp -> e.state <- Exponent ; + | (Integral|Fraction) , Plus -> e.sign <- Positive + | (Integral|Fraction) , Minus -> e.sign <- Negative + | Integral , Digit -> Buffer.add_char e.mantiss c + | Fraction , Digit -> Buffer.add_char e.mantiss c ; e.coma <- succ e.coma + | Exponent , (Plus|Minus|Digit) -> Buffer.add_char e.exponent c + ) r ; + let m = Buffer.contents e.mantiss in + begin + match trail m with + | None -> "0" + | Some(a,b) -> + let digits = String.sub m a (String.length m - a - b) in + let exp = + let ex = Buffer.contents e.exponent in + if ex = "" then b - e.coma else int_of_string ex + b - e.coma + in + let size = 4 + String.length m + abs exp in + let buffer = Buffer.create size in + let parent = e.sign = Negative || exp <> 0 in + if parent then Buffer.add_char buffer '(' ; + if e.sign = Negative then Buffer.add_char buffer '-' ; + Buffer.add_string buffer digits ; + if exp > 0 then Buffer.add_string buffer (String.make exp '0') ; + if exp < 0 then + (Buffer.add_string buffer "/1" ; + Buffer.add_string buffer (String.make (-exp) '0')) ; + if parent then Buffer.add_char buffer ')' ; + Buffer.contents buffer + end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/kreal.mli frama-c-20111001+nitrogen+dfsg/src/wp/kreal.mli --- frama-c-20110201+carbon+dfsg/src/wp/kreal.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/kreal.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,25 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Converting real constants with only integral values *) + +val convert : string -> string diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicDef.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicDef.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicDef.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicDef.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,447 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Logic Database --- ) +( -------------------------------------------------------------------------- ) + +open LogicId +open LogicTau +open LogicLang + +type item = + | TYPE of int + | RECORD of field list + | FUNCTION of var list tau * term option + | PREDICATE of var list * pred option + | AXIOM of pred + +type description = { + t_source : Lexing.position ; + t_short : string ; + t_descr : string ; +} + +type declaration = { + d_name : id ; + d_item : item ; + d_descr : description ; +} + +type registered = { + r_declaration : declaration ; + r_localdeps : Iset.t ; + r_age : int ; +} + +type logic_model = { + model_name : string ; + model_pointer : tau ; + model_index : registered Ihmap.t ; + mutable model_locked : Iset.t ; (* cofix compiled ) + mutable model_history : int ; ( age of exportations ) + mutable model_updated : bool ; ( modified at this age ) +} + +module LogicModel : Datatype.S with type t = logic_model = + Datatype.Make + (struct + include Datatype.Undefined + type t = logic_model + let name = "Wp.LogicDef.LogicModel" + let reprs = [{ + model_name=""; + model_pointer = Integer; + model_index = Ihmap.create 0; + model_locked = Iset.empty ; + model_history = 0; + model_updated = false; + }] + end) + +module MODELS = State_builder.Hashtbl(Datatype.String.Hashtbl)(LogicModel) + (struct + let name = "Wp.LogicDef.Declarations" + let dependencies = [Ast.self] + let kind = `Tuning ( TODO[LC]: to check with JS. ) + let size = 7 + end) + +let register ~name ~pointer = + if MODELS.mem name then Wp_parameters.fatal "Duplicate logic model {%s}" name ; + MODELS.add name { + model_name = name ; + model_pointer = pointer ; + model_index = Ihmap.create 231 ; + model_locked = Iset.empty ; + model_history = 0 ; + model_updated = false ; + } + +let current_model = ref None + +let on_model model job data = + match !current_model with + | Some m -> + Wp_parameters.fatal + "Re-entrant logic model {%s,%s}" m.model_name model + | None -> + current_model := Some (MODELS.find model) ; + try let result = job data in current_model := None ; result + with exn -> current_model := None ; raise exn + +let the_model () = + match !current_model with Some m -> m | None -> + Wp_parameters.fatal "No logic model" + +( -------------------------------------------------------------------------- ) +( --- Registry --- ) +( -------------------------------------------------------------------------- ) + +let lookup id = + let model = the_model () in + Ihmap.find model.model_index id + +let get_item id = (lookup id).r_declaration.d_item +let get_description id = (lookup id).r_declaration.d_descr +let get_declaration id = (lookup id).r_declaration +let get_local_depends id = + try (lookup id).r_localdeps with Not_found -> Iset.empty + +let add_depend_var ids x = add_depend_tau ids (tau_of_var x) +let add_depend_field ids f = add_depend_tau ids f.f_type + +let dependencies = function + | TYPE _ -> Iset.empty + | RECORD fs -> List.fold_left add_depend_field Iset.empty fs + | FUNCTION (xs,t,None) -> + List.fold_left add_depend_var (add_depend_tau Iset.empty t) xs + | FUNCTION (xs,t,Some e) -> + let core = add_depend_term Iset.empty e in + List.fold_left add_depend_var (add_depend_tau core t) xs + | PREDICATE(xs,None) -> + List.fold_left add_depend_var Iset.empty xs + | PREDICATE(xs,Some p) -> + List.fold_left add_depend_var (add_depend_pred Iset.empty p) xs + | AXIOM p -> add_depend_pred Iset.empty p + +let declare d = + let m = the_model () in + if Iset.mem d.d_name m.model_locked then + Wp_parameters.fatal "Locked symbol '%a'" LogicId.pretty d.d_name ; + m.model_updated <- true ; + Ihmap.replace m.model_index d.d_name { + r_declaration = d ; + r_age = m.model_history ; + r_localdeps = dependencies d.d_item ; + } + +let lock f = + let m = the_model () in + m.model_locked <- Iset.add f m.model_locked + +let unlock f = + let m = the_model () in + m.model_locked <- Iset.remove f m.model_locked + +let mark_history () = + let m = the_model () in + if m.model_updated then + ( m.model_history <- succ m.model_history ; m.model_updated <- false ) + +let model_age () = (the_model ()).model_history + +( -------------------------------------------------------------------------- ) +( --- Fixpoint Compilation --- ) +( -------------------------------------------------------------------------- ) + +module Cofix = +struct + + let stack : id list ref = ref [] + let push f = stack := f :: !stack + let pop f = + match !stack with + | [] -> Wp_parameters.fatal "Logic.cofix: empty stack" + | f0::stk -> + if LogicId.equal f f0 then stack := stk + else Wp_parameters.fatal "Logic.cofix: corrupted stack" + + let recursive f = + List.exists (LogicId.equal f) !stack + + type state = + | Undefined + | Defined of item + | Cyclic of cycle + + and cycle = { + mutable ccitem : ccitem ; + mutable stable : bool ; ( stable or not during fixpoint ) + mutable inners : Iset.t ; ( set of symbols in the cycle, except root ) + } and ccitem = + | Cnone + | Cdefault of item + | Cupdated of item description + + let cofix : cycle Ihmap.t = Ihmap.create 31 (* Cycle state only ) + + let lookup f = + try Defined(get_item f) + with Not_found -> + try Cyclic(Ihmap.find cofix f) + with Not_found -> Undefined + + let is_stable f = match lookup f with + | Undefined | Defined _ + | Cyclic { ccitem=Cupdated _ ; stable=true } -> true + | Cyclic _ -> false + + let current = function + | Cnone -> + Wp_parameters.fatal "logic:undefined value" + | Cdefault item | Cupdated(item,_) -> item + + let define f = + try + let c = Ihmap.find cofix f in + Ihmap.remove cofix f ; + match c.ccitem with + | Cnone | Cdefault _ -> + Wp_parameters.fatal "unstable definition (%a)" LogicId.pretty f ; + | Cupdated (item,descr) -> + unlock f ; + declare { d_name=f ; d_item=item ; d_descr=descr } + with Not_found -> () + + let is_stable f = + match lookup f with + | Undefined -> false + | Defined _ -> true + | Cyclic c -> c.stable + + exception Unstable + + let all_stable fs = + try Iset.iter + (fun f -> + if not (is_stable f) then raise Unstable + ) fs ; true + with Unstable -> false + + let set_stable f = + try let c = Ihmap.find cofix f in c.stable <- true + with Not_found -> () + + let rec get_cycle f = function + | [] -> [] + | g::stk -> if LogicId.equal f g then [] else (g :: get_cycle f stk) + + let add_cycle fs g = + try + let c = Ihmap.find cofix g in + c.inners <- List.fold_right Iset.add fs c.inners + with Not_found -> () + + let rec compatible_signature xs ys = + match xs , ys with + | [] , [] -> true + | [] , _ | _ , [] -> false + | x::xs , y::ys -> + (compare_tau (tau_of_var x) (tau_of_var y) = 0) && + compatible_signature xs ys + + let compatible item0 item1 = + match item0,item1 with + | FUNCTION(_,_,Some _) , FUNCTION(_,_,None) -> false + | PREDICATE(_,Some _) , PREDICATE(_,None) -> false + | FUNCTION(sig0,r0,_) , FUNCTION(sig1,r1,_) -> + (compatible_signature sig0 sig1) && + (compare_tau r0 r1 = 0) + | PREDICATE(sig0,_) , PREDICATE(sig1,_) -> + (compatible_signature sig0 sig1) + | TYPE n , TYPE n' -> n=n' + | RECORD fs , RECORD fs' -> + (List.length fs = List.length fs') && + List.for_all2 (fun f f' -> compare_field f f'=0) fs fs' + | AXIOM _ , AXIOM _ -> true + | _ -> false + + let default f item = + try + let c = Ihmap.find cofix f in + if c.ccitem=Cnone then c.ccitem <- Cdefault item + with Not_found -> + Ihmap.add cofix f { + ccitem = Cdefault item ; + stable = true ; + inners = Iset.empty ; + } + + let update f item descr = + match lookup f with + | Undefined | Defined _ -> + declare { d_name=f ; d_item=item ; d_descr=descr } + | Cyclic c -> + if c.stable then + begin + match c.ccitem with + | Cnone -> () + | Cdefault item0 | Cupdated(item0,_) -> + c.stable <- compatible item0 item + end ; + c.ccitem <- Cupdated(item,descr) + + let compute f cc = + try push f ; cc f ; pop f ; + with error -> pop f ; raise error + + let rec fixpoint c f cc = + compute f cc ; + if Iset.mem f c.inners then + ( inside cycle ) + ( current c.ccitem ) + else + ( cycle root ) + if c.stable && all_stable c.inners then + begin + define f ; + Iset.iter define c.inners ; + current c.ccitem + end + else + begin + c.stable <- true ; + Iset.iter set_stable c.inners ; + fixpoint c f cc + end + + let obtain f cc = + match lookup f with + | Defined item -> item + | Undefined -> + let c = { ccitem=Cnone ; stable=true ; inners=Iset.empty } in + Ihmap.replace cofix f c ; + lock f ; fixpoint c f cc + | Cyclic c -> + if recursive f then + let fs = get_cycle f !stack in + List.iter (add_cycle fs) (f::fs) ; + ( current c.ccitem ) + else + ( fixpoint c f cc ) + +end + +let fixpoint = Cofix.obtain +let default = Cofix.default +let update = Cofix.update + +( -------------------------------------------------------------------------- ) +( --- Exportation --- ) +( -------------------------------------------------------------------------- ) + + +module Components = +struct + + ([LC] From ocamlgraph/components with added feature ) + + module G = + struct + ( here, G.t = unit and G.V=LogicId ) + let iter_succ f (g*) id = Iset.iter f (get_local_depends id) + end + module H = Ihmap + module S = Iset + + ([LC] Added an iterator for some 'roots' There is no need for + G.iter_vertex. Only an iterator over the requested nodes is + necessary. The compute hashcomp table is enough to build the + array of components. ) + + let scc_roots (g) iter_roots = + let root = H.create 997 in + let hashcomp = H.create 997 in + let stack = ref [] in + let numdfs = ref 0 in + let numcomp = ref 0 in + let rec pop x c = function + | (y, w) :: l when y > x -> + H.add hashcomp w !numcomp; + pop x (S.add w c) l + | l -> c,l + in + let rec visit v = + if not (H.mem root v) then + begin + let n = incr numdfs; !numdfs in + H.add root v n; + G.iter_succ + (fun w -> + visit w; + if not (H.mem hashcomp w) then + H.replace root v (min (H.find root v) (H.find root w))) + (g) v; + if H.find root v = n then + (H.add hashcomp v !numcomp; + let _,s = pop n (S.add v S.empty) !stack in + stack:= s; + incr numcomp) + else stack := (n,v)::!stack; + end + in + iter_roots visit (g) ; + let t = Array.make !numcomp [] in + H.iter + (fun v i -> t.(i) <- v::t.(i)) + hashcomp ; t + +end + +let declarations ids = + let section = function + | TYPE _ | RECORD _ -> 0 + | FUNCTION _ -> 1 + | PREDICATE _ -> 2 + | AXIOM _ -> 3 + in + let sort d1 d2 = section d1.d_item - section d2.d_item in + let acc = ref [] in + List.iter + (fun f -> + try acc := get_declaration f :: !acc + with Not_found -> ()) + ids ; + List.sort sort !acc + +let export f roots_iter = + Array.iter + (fun ids -> f (declarations ids)) + (Components.scc_roots roots_iter) + +let export_items f ids = + export f (fun visit -> List.iter visit ids) + +let export_goal f p = + let ids = add_depend_pred Iset.empty p in + export f (fun visit -> Iset.iter visit ids) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicDef.mli frama-c-20111001+nitrogen+dfsg/src/wp/LogicDef.mli --- frama-c-20110201+carbon+dfsg/src/wp/LogicDef.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicDef.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,99 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Logic Database ) +( -------------------------------------------------------------------------- *) + +open LogicId +open LogicTau +open LogicLang + +(** {3 Model Registration} *) + +val register : name:string -> pointer:tau -> unit +val on_model : string -> ('a -> 'b) -> 'a -> 'b + +(** {3 Declarations} ) + +type item = + | TYPE of int + | RECORD of field list + | FUNCTION of var list tau * term option + | PREDICATE of var list * pred option + | AXIOM of pred + +type description = { + t_source : Lexing.position ; + t_short : string ; + t_descr : string ; +} + +type declaration = { + d_name : id ; + d_item : item ; + d_descr : description ; +} + +val declare : declaration -> unit (** Simple declaration. *) + +(** {3 Recursive Compilations} *) + +val fixpoint : id -> (id -> unit) -> item + (** Retrieve the definition of [f] if already defined. + Otherwise compile it with the provided compiler. + + The compiler should set an initial value with [default] before + any recursive call to [fixpoint]. Then, the compiler should + updates item for [f] or any other mutually-recursive symbol with + [f] by using [update]. It is a fatal-error to call [declare] on + a symbol currently compiled by [fixpoint]. + + The mutually recursive calls to [fixpoint] are detected, and + associated compilers are run until stabilisation. All + mutually-recursive symbols are finally declared and defined with + their last updates. *) + +val default : id -> item -> unit +val update : id -> item -> description -> unit + +(** {3 Retrieving Definitions} *) + +val get_item : id -> item + (** Raise [Not_found] if the symbol is undefined. *) + +val get_description : id -> description + (** Raise [Not_found] if the symbol is undefined. *) + +val get_declaration : id -> declaration + (** Raise [Not_found] if the symbol is undefined. ) + +( -------------------------------------------------------------------------- ) +( --- History Management --- ) +( -------------------------------------------------------------------------- ) + +val mark_history : unit -> unit +val model_age : unit -> int + +val export_items : (declaration list -> unit) -> id list -> unit +val export_goal : (declaration list -> unit) -> pred -> unit + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicHavoc.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicHavoc.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicHavoc.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicHavoc.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,140 @@ +( -------------------------------------------------------------------------- ) +( --- Havoc --- ) +( -------------------------------------------------------------------------- ) + +open LogicId +open LogicTau +open LogicLang + +type region = + | Full + | Empty + | Field of field_region list ( SORTED & MERGED ) + | Index of tau list index_region list (* SAME SIGNATURE ) + +and field_region = field region +and index_region = ( term list -> pred ) * region (* FULL or FIELD region ) + +( -------------------------------------------------------------------------- ) +( --- Merge Operations --- ) +( -------------------------------------------------------------------------- ) + +let rec merge_signature ts1 ts2 = + match ts1,ts2 with + | [],ts | ts,[] -> ts + | t1::ts1 , t2::ts2 -> + if compare_tau t1 t2 <> 0 then + failwith "merge incompatible index during havoc" ; + t1 :: merge_signature ts1 ts2 + +let rec merge r1 r2 = + match r1 , r2 with + | Full , _ | _ , Full -> Full + | Empty , r | r , Empty -> r + | Field _ , Index _ | Index _ , Field _ -> + failwith "merge field and index during havoc" + | Field fs1 , Field fs2 -> Field (merge_fields fs1 fs2) + | Index (ts1,ks1) , Index (ts2,ks2) -> + let ts = merge_signature ts1 ts2 in + Index( ts , ks1 @ ks2 ) ( Extension is natural ) + +and merge_fields fs1 fs2 = + match fs1 , fs2 with + | [] , fs | fs , [] -> fs + | ((f1,r1) as h1)::ftail1 , ((f2,r2) as h2)::ftail2 -> + let cmp = compare_field f1 f2 in + if cmp < 0 then h1 :: merge_fields ftail1 fs2 else + if cmp > 0 then h2 :: merge_fields fs1 ftail2 else + (f1 , merge r1 r2) :: merge_fields ftail1 ftail2 + +( -------------------------------------------------------------------------- ) +( --- Constructors --- ) +( -------------------------------------------------------------------------- ) + +let rec shift d = function + | _::xs when d>0 -> shift (pred d) xs + | xs -> xs + +let fsort (f1,_) (f2,_) = compare_field f1 f2 + +let empty = Empty +let full = Full + +let field fs f r = + if r = Empty then Empty else + Field (List.map + (fun g -> g , if compare_field f g = 0 then r else Empty) + (List.sort compare_field fs)) + +let fields frs = + if List.for_all (fun (_,r) -> r = Empty) frs then Empty else + if List.for_all (fun (_,r) -> r = Full) frs then Full else + Field (List.sort fsort frs) + +let matrix ts cond = function + | Empty -> Empty + | (Field _ | Full) as r -> Index(ts,[cond,r]) + | Index(ts0,kregions) -> + let d = List.length ts in + let gregions = List.map + (fun (cond0,r0) -> + let gcond = fun xs -> p_and (cond xs) (cond0 (shift d xs)) in + gcond , r0) + kregions + in + Index( ts @ ts0 , gregions ) + +let array t cond = function + | Empty -> Empty + | region -> matrix [t] (fun ts -> cond (List.hd ts)) region + +let in_range a b k = p_and (p_icmp Cleq a k) (p_icmp Cleq k b) +let index term r = array Integer (p_equal term) r +let range a b r = array Integer (in_range a b) r + +( -------------------------------------------------------------------------- ) +( --- Havoc Relation --- ) +( -------------------------------------------------------------------------- ) + +let forall xs p = List.fold_right p_forall xs p +let access a ks = List.fold_left e_access a ks + +let only_one_region vs kregions : ( pred region ) list = + let kregions = Array.of_list kregions in + Array.to_list + (Array.mapi + (fun i (_,region) -> + let conds_i = + Array.mapi + (fun j (cond,_) -> + let p = cond vs in + if i=j then p else p_not p) + kregions + in + p_conj (Array.to_list conds_i) , region + ) kregions) + +let rec is_havoc pool x1 x2 = function + | Empty -> p_equal x1 x2 + | Full -> p_true + | Field fs -> + List.fold_left + (fun w (f,r) -> + p_and w (is_havoc pool (e_getfield x1 f) (e_getfield x2 f) r)) + p_true fs + | Index(ts,ks) -> + let xs = List.map (LogicLib.fresh pool) ts in + let vs = List.map e_var xs in + let a1_xs = access x1 vs in + let a2_xs = access x2 vs in + let all_diff_then_equal = + forall xs + (p_implies + (p_conj (List.map (fun (cond,_) -> p_not (cond vs)) ks)) + (p_equal a1_xs a2_xs)) in + let only_once_then_region = + List.map + (fun (condition,region) -> + forall xs (p_implies condition (is_havoc pool a1_xs a2_xs region)) + ) (only_one_region vs ks) in + p_conj (all_diff_then_equal :: only_once_then_region) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicHavoc.mli frama-c-20111001+nitrogen+dfsg/src/wp/LogicHavoc.mli --- frama-c-20110201+carbon+dfsg/src/wp/LogicHavoc.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicHavoc.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,21 @@ + +open LogicId +open LogicTau +open LogicLang + +type region + +val empty : region +val full : region + +val fields : ( field * region ) list -> region +val field : field list -> field -> region -> region + (** [field fs f r] is [empty] for all [fs] except [f] for which it is [r] *) + +val index : term -> region -> region +val range : term -> term -> region -> region +val array : tau -> (term -> pred) -> region -> region +val matrix : tau list -> (term list -> pred) -> region -> region + +val is_havoc : pool -> term -> term -> region -> pred + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicId.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicId.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicId.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicId.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,257 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Logic Identifiers --- ) +( -------------------------------------------------------------------------- ) + +type id = string int + +module S = +struct + + type t = id + let compare = Pervasives.compare + let hash = Hashtbl.hash + let equal = (=) + let pretty fmt (x,k) = Format.fprintf fmt "%s%%%d" x k + +end + +include S + +module Iset = Set.Make(S) +module Imap = Map.Make(S) +module Ihmap = Hashtbl.Make(S) +module Kset = Set.Make(String) +module Kmap = Map.Make(String) + +let idref = ref 0 +let idfree = ref [] +let dummy = ("",0) +let extern = ref Kmap.empty + +let create a = + match !idfree with + | [] -> incr idref ; a , !idref + | k::ks -> idfree := ks ; a , k + +let basename a = fst a + +let library lnk = + try Kmap.find lnk !extern + with Not_found -> + let eid = create lnk in + extern := Kmap.add lnk eid !extern ; eid + +type allocator = { + mutable index : int ; (* last used indice ) + mutable free : int list ; ( free list ) + mutable based : bool ; ( base only allocated ) + mutable count : int ; ( touched ) +} + +type space = { + mutable alloc : (string,allocator) Hashtbl.t ; + mutable locals : Iset.t ; + mutable reserved : Kset.t ; + indices : indice Ihmap.t ; +} and indice = + | Base | Idx of int | Link of string + +let allocator space base = + try Hashtbl.find space.alloc base + with Not_found -> + let a = { index=0 ; based=false ; free=[] ; count=0 } in + Hashtbl.add space.alloc base a ; a + +let unalloc space id = + idfree := snd id :: !idfree ; + try + let k = Ihmap.find space.indices id in + let a = Hashtbl.find space.alloc (fst id) in + match k with + | Base -> a.based <- false + | Idx k -> a.free <- k :: a.free + | Link k -> space.reserved <- Kset.remove k space.reserved + with Not_found -> () + +let push space a = + let id = create a in + space.locals <- Iset.add id space.locals ; id + +let pop space id = + if not (Iset.mem id space.locals) then + Wp_parameters.fatal "LogicId: non-local %a" pretty id ; + space.locals <- Iset.remove id space.locals ; + unalloc space id + +type mark = Iset.t + +let mark space = space.locals +let unmark space mark = + Iset.iter + (fun id -> + if not (Iset.mem id mark) then unalloc space id + ) space.locals ; + space.locals <- mark + +let clear space = + Iset.iter (unalloc space) space.locals ; + space.locals <- Iset.empty + +let reserve1 space key = + if Kset.mem key space.reserved then + Wp_parameters.fatal "Already reserved name '%s'" key ; + space.reserved <- Kset.add key space.reserved ; + try + let a = Hashtbl.find space.alloc key in + if a.based then Wp_parameters.fatal + "Reserved name '%s' clashes with named identifier" key + with Not_found -> () + +let reserved space = List.iter (reserve1 space) + +let link space id key = + reserve1 space key ; + Ihmap.add space.indices id (Link key) + +let space () = + let s = { + alloc = Hashtbl.create 131 ; + locals = Iset.empty ; + indices = Ihmap.create 257 ; + reserved = Kset.empty ; + } in + Kmap.iter (fun lnk id -> link s id lnk) !extern ; s + +let indice space unique id = + try Ihmap.find space.indices id + with Not_found -> + let base = fst id in + let a = allocator space base in + let idx = + if not a.based && + (unique || ( a.index=0 && a.count=1 )) && + not (Kset.mem base space.reserved) + then (a.based <- true ; Base) + else match a.free with + | [] -> + let k = succ a.index in + a.index <- k ; Idx k + | k::ks -> + a.free <- ks ; Idx k + in + Ihmap.add space.indices id idx ; idx + +let name space ?(unique=false) id = + match indice space unique id with + | Base -> fst id + | Idx k -> Printf.sprintf "%s_%d" (fst id) k + | Link s -> s + +let unique space id = ignore (indice space true id) + +let pp_id space fmt id = + match indice space false id with + | Base -> Format.pp_print_string fmt (fst id) + | Idx k -> Format.fprintf fmt "%s_%d" (fst id) k + | Link s -> Format.pp_print_string fmt s + +let touch space id = + let a = allocator space (fst id) in + a.count <- succ a.count + +let copy space = { + alloc = Hashtbl.copy space.alloc ; + indices = Ihmap.copy space.indices ; + locals = space.locals ; + reserved = space.reserved ; +} + +let iter f space = + Ihmap.iter + (fun id idx -> + let name = match idx with + | Base -> fst id + | Idx k -> Printf.sprintf "%s_%d" (fst id) k + | Link s -> s + in f id name) + space.indices + +( -------------------------------------------------------------------------- ) +( --- Alphanumerical Sorting --- ) +( -------------------------------------------------------------------------- *) + +type tk = Letter | Digit | Symbol | End + +let letter s k = + if k < String.length s then + let c = s.[k] in + if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') then Letter + else if ('0' <= c && c <= '9') then Digit else Symbol + else End + +let rec extend s k u = + let k = succ k in + let v = letter s k in + if v == u then extend s k u else k + +let rec compare_token a b ka kb = + let ca = letter a ka in + let cb = letter b kb in + match ca , cb with + | End , End -> 0 + | End , _ -> (-1) + | _ , End -> 1 + | Letter , Letter -> + let pa = extend a ka Letter in + let pb = extend b kb Letter in + let sa = String.sub a ka (pa-ka) in + let sb = String.sub b kb (pb-kb) in + let ua = String.uppercase sa in + let ub = String.uppercase sb in + let ucmp = String.compare ua ub in + if ucmp <> 0 then ucmp else + let scmp = String.compare sa sb in + if scmp <> 0 then scmp else + compare_token a b pa pb + | Letter , _ -> (-1) + | _ , Letter -> 1 + | Digit , Digit -> + let pa = extend a ka Digit in + let pb = extend b kb Digit in + let sa = String.sub a ka (pa-ka) in + let sb = String.sub b kb (pb-kb) in + let kcmp = Pervasives.compare (int_of_string sa) (int_of_string sb) in + if kcmp <> 0 then kcmp else + let scmp = String.compare sa sb in + if scmp <> 0 then scmp else + compare_token a b pa pb + | Digit , _ -> (-1) + | _ , Digit -> 1 + | Symbol , Symbol -> + let cmp = Char.compare a.[ka] b.[kb] in + if cmp <> 0 then cmp else + compare_token a b (succ ka) (succ kb) + +let alpha x y = compare_token x y 0 0 diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicId.mli frama-c-20111001+nitrogen+dfsg/src/wp/LogicId.mli --- frama-c-20110201+carbon+dfsg/src/wp/LogicId.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicId.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,89 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Logical Identifiers *) + +type id +val library : string -> id (** Returns an id for an external symbol *) +val create : string -> id (** Create a new fresh identifier with the given basename *) +val basename : id -> string + +(** {3 Datatype} *) + +type t = id +val compare : id -> id -> int +val equal : id -> id -> bool +val hash : id -> int +val pretty : Format.formatter -> id -> unit +val dummy : id (** Only usable for represent in projectified definitions *) + +(** {3 Map and Set} *) + +module Iset : Set.S with type elt = t +module Imap : Map.S with type key = t +module Ihmap : Hashtbl.S with type key = t + +(** {3 Name Spaces} *) + +type space +val space : unit -> space (** Creates an empty name space (but with the external names). *) +val copy : space -> space (** Duplicates a name space. *) + +val link : space -> id -> string -> unit + (** Link the identifier to some absolute name. + Also reserves this name. *) + +val reserved : space -> string list -> unit + (** Reserves the given names to avoid clash with generated ones. *) + +val name : space -> ?unique:bool -> id -> string + (** Assigns a unique string to an identifier in the space. + When flag [unique] is set to true, the generated name + is preferrably the basename of the identifier. *) + +val pp_id : space -> Format.formatter -> id -> unit + (** Combines [name] and [Format]. *) + +val unique : space -> id -> unit + (** Reserves the identifier to be assigned its basename as name, if possible. + Same as using [name space ~unique:true id]. *) + +val touch : space -> id -> unit + (** Count the identifier in the space. + If the identifier has been counted exactly once, + the first time its name is asked, the basename would be + assigned to it. ) + +val push : space -> string -> id ( Allocate a local identifier in the space name ) +val pop : space -> id -> unit ( Deallocate a local identifier from the space name ) +val clear : space -> unit ( Deallocate all local identifiers ) + +type mark +val mark : space -> mark ( Marks all current locals ) +val unmark : space -> mark -> unit ( Deallocate non-marked locals *) + +val iter : (id -> string -> unit) -> space -> unit + +(** {3 Sorting} *) + +val alpha : string -> string -> int + (** User-friendly name sorting. Namely: [a<A<b] and [1<10]. *) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicLang.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicLang.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicLang.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicLang.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,214 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Logical Language --- ) +( -------------------------------------------------------------------------- ) + +open LogicTau +open LogicRaw + +( -------------------------------------------------------------------------- ) +( --- Primitives --- ) +( -------------------------------------------------------------------------- ) + +type integer_op = Iadd | Isub | Imul | Idiv | Imod +type real_op = Radd | Rsub | Rmul | Rdiv +type cmp_op = Ceq | Cneq | Clt | Cleq + +( -------------------------------------------------------------------------- ) +( --- Primitives --- ) +( -------------------------------------------------------------------------- ) + +type term = TERM.t +type pred = PRED.t + +let e_call f ts = TERM.e_call f ts +let p_call f xs = PRED.p_call f xs + +( -------------------------------------------------------------------------- ) +( --- Arithmetics --- ) +( -------------------------------------------------------------------------- ) + +let e_true = TERM.Ttrue +let e_false = TERM.Tfalse +let e_zero = TERM.e_zero +let e_int = TERM.e_int +let e_float k = TERM.Treal(string_of_float k) +let e_bigint z = TERM.Tint(My_bigint.to_string z) +let e_icst z = TERM.Tint z +let e_rcst z = TERM.Treal z + +let unop f a = TERM.e_prim f [a] +let binop f a b = TERM.e_prim f [a;b] +let predop f a b = PRED.p_prim f [a;b] + +let i_pred = function + | Ceq -> PRED.L_eq + | Cneq -> PRED.L_neq + | Clt -> PRED.I_lt + | Cleq -> PRED.I_leq + +let i_bool = function + | Ceq -> TERM.L_eq + | Cneq -> TERM.L_neq + | Clt -> TERM.I_lt + | Cleq -> TERM.I_leq + +let i_op = function + | Iadd -> TERM.I_add + | Isub -> TERM.I_sub + | Imul -> TERM.I_mul + | Idiv -> TERM.I_div + | Imod -> TERM.I_mod + +let r_pred = function + | Ceq -> PRED.L_eq + | Cneq -> PRED.L_neq + | Clt -> PRED.R_lt + | Cleq -> PRED.R_leq + +let r_bool = function + | Ceq -> TERM.L_eq + | Cneq -> TERM.L_neq + | Clt -> TERM.R_lt + | Cleq -> TERM.R_leq + +let r_op = function + | Radd -> TERM.R_add + | Rsub -> TERM.R_sub + | Rmul -> TERM.R_mul + | Rdiv -> TERM.R_div + +let e_ineg = unop TERM.I_opp +let e_rneg = unop TERM.R_opp + +let e_icmp op = binop (i_bool op) +let p_icmp op = predop (i_pred op) + +let e_rcmp op = binop (r_bool op) +let p_rcmp op = predop (r_pred op) + +let p_equal = predop PRED.L_eq +let p_neq = predop PRED.L_neq + +let e_iop op = binop (i_op op) +let e_rop op = binop (r_op op) + +let e_real_of_int = unop TERM.R_of_I +let e_int_of_real = unop TERM.I_of_R + +let a_true = e_int 1 +let a_false = e_int 0 + +let e_bool c = TERM.e_cond c a_true a_false +let e_cond c a b = TERM.e_cond c a b + +let e_not = TERM.e_not +let e_and = TERM.e_and +let e_or = TERM.e_or + +let e_bnot = unop TERM.I_bnot +let e_band = binop TERM.I_band +let e_bor = binop TERM.I_bor +let e_bxor = binop TERM.I_bxor +let e_lshift = binop TERM.I_lsl +let e_rshift = binop TERM.I_lsr + +let e_getfield = TERM.e_getfield +let e_setfield = TERM.e_setfield +let e_access = TERM.e_access +let e_update = TERM.e_update + +( -------------------------------------------------------------------------- ) +( --- Predicates --- ) +( -------------------------------------------------------------------------- ) + +let p_true = PRED.Ptrue +let p_false = PRED.Pfalse +let p_bool = PRED.p_bool +let p_not = PRED.p_not +let p_implies = PRED.p_implies +let p_and = PRED.p_and +let p_or = PRED.p_or +let p_xor = PRED.p_xor +let p_iff = PRED.p_iff +let p_cond = PRED.p_cond + +let p_named label p = PRED.Pnamed(label,p) +let p_hide p = p + +let rec p_conj = function + | [] -> PRED.Ptrue | [p] -> p + | p::ps -> PRED.p_and p (p_conj ps) + +let rec p_disj = function + | [] -> PRED.Pfalse | [p] -> p + | p::ps -> PRED.p_or p (p_disj ps) + +let rec p_goal hs p = match hs with + | [] -> p + | h::hs -> PRED.p_implies h (p_goal hs p) + +( -------------------------------------------------------------------------- ) +( --- Variables --- ) +( -------------------------------------------------------------------------- ) + +type var = VAR.t +type pool = VAR.pool + +let tau_of_var = VAR.tau_of_var +let pool = VAR.pool +let fresh = VAR.fresh +let e_var x = TERM.Tvar x +let e_let = SUBST.e_let +let p_let = SUBST.p_let +let p_forall = PRED.p_forall +let p_exists = PRED.p_exists +let is_atomic = SUBST.is_atomic + +module Vmap = VMAP +module Vset = VSET + +( -------------------------------------------------------------------------- ) +( --- PRETTY PRINTING --- ) +( -------------------------------------------------------------------------- ) + +let space = LogicId.space () +let () = LogicId.reserved space [ + "if" ; "then" ; "let" ; "in" ; + "pointer" ; + "and" ; "or" ; "not" ; "forall" ; "exists" ; +] + +let pretty = new LogicPretty.engine space +let pp_tau = pretty#pp_tau +let pp_term = pretty#alpha pretty#pp_term +let pp_pred = pretty#alpha pretty#pp_pred + +( -------------------------------------------------------------------------- ) +( --- DEPENDENCIES --- ) +( -------------------------------------------------------------------------- *) + +let add_depend_tau = LogicTau.depend +let add_depend_term = TERM.depend +let add_depend_pred = PRED.depend diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicLang.mli frama-c-20111001+nitrogen+dfsg/src/wp/LogicLang.mli --- frama-c-20110201+carbon+dfsg/src/wp/LogicLang.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicLang.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,151 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Logical Language ) +( -------------------------------------------------------------------------- ) + +open LogicId +open LogicTau + +( -------------------------------------------------------------------------- *) +(** {2 Primitives} ) +( -------------------------------------------------------------------------- ) + +type integer_op = Iadd | Isub | Imul | Idiv | Imod +type real_op = Radd | Rsub | Rmul | Rdiv +type cmp_op = Ceq | Cneq | Clt | Cleq + +( -------------------------------------------------------------------------- *) +(** {2 Terms} ) +( -------------------------------------------------------------------------- *) + +type term + +(** {3 Primitives} *) + +val e_true : term +val e_false : term +val e_zero : term +val e_int : int -> term +val e_float : float -> term +val e_bigint : My_bigint.t -> term +val e_icst : string -> term +val e_rcst : string -> term + +(** {3 Arithmetics} *) + +val e_ineg : term -> term +val e_rneg : term -> term +val e_iop : integer_op -> term -> term -> term +val e_rop : real_op -> term -> term -> term +val e_icmp : cmp_op -> term -> term -> term +val e_rcmp : cmp_op -> term -> term -> term + +val e_bnot : term -> term +val e_band : term -> term -> term +val e_bor : term -> term -> term +val e_bxor : term -> term -> term +val e_lshift : term -> term -> term +val e_rshift : term -> term -> term + +val e_int_of_real : term -> term +val e_real_of_int : term -> term + +(** {3 Booleans} *) + +val e_not : term -> term +val e_and : term -> term -> term +val e_or : term -> term -> term + +(** {3 Structures} *) + +val e_getfield : term -> field -> term +val e_setfield : term -> field -> term -> term +val e_access : term -> term -> term +val e_update : term -> term -> term -> term + +(** {2 Predicates} *) + +type pred + +val p_true : pred +val p_false : pred +val p_bool : term -> pred +val p_not : pred -> pred +val p_and : pred -> pred -> pred +val p_or : pred -> pred -> pred +val p_xor : pred -> pred -> pred +val p_implies : pred -> pred -> pred +val p_iff : pred -> pred -> pred + +val p_icmp : cmp_op -> term -> term -> pred +val p_rcmp : cmp_op -> term -> term -> pred +val p_equal : term -> term -> pred +val p_neq : term -> term -> pred + +val p_conj : pred list -> pred +val p_disj : pred list -> pred +val p_goal : pred list -> pred -> pred + +(** {2 Generic Terms and Formulas} *) + +val e_call : id -> term list -> term +val p_call : id -> term list -> pred + +val e_cond : term -> term -> term -> term +val p_cond : term -> pred -> pred -> pred + +val p_named : id -> pred -> pred +val p_hide : pred -> pred + +(** {2 Variables} *) + +type var +type pool + +val pool : unit -> pool +val fresh : pool -> string -> tau -> var + +val e_var : var -> term +val e_let : ?pool:pool -> var -> term -> term -> term +val p_let : ?pool:pool -> var -> term -> pred -> pred +val p_forall : var -> pred -> pred +val p_exists : var -> pred -> pred + +val tau_of_var : var -> tau +val is_atomic : term -> bool + +module Vset : Set.S with type elt = var +module Vmap : Map.S with type key = var + +(** {2 Pretty Printers} *) + +val pp_tau : Format.formatter -> tau -> unit +val pp_term : Format.formatter -> term -> unit +val pp_pred : Format.formatter -> pred -> unit + +(** {2 Dependencies} ) + +val add_depend_tau : Iset.t -> tau -> Iset.t +val add_depend_term : Iset.t -> term -> Iset.t +val add_depend_pred : Iset.t -> pred -> Iset.t diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicLib.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicLib.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicLib.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicLib.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,28 @@ +( -------------------------------------------------------------------------- ) +( --- LogicLang Tools w.r.t access paths --- ) +( -------------------------------------------------------------------------- *) + +open LogicTau +open LogicLang + +let basename = function + | Integer -> "k" + | Real -> "z" + | Boolean -> "c" + | Pointer -> "p" + | ADT(id,_) | Record id -> LogicId.basename id + | Array _ -> "A" + | Set _ -> "S" + | ALPHA _ -> "x" + +let fresh pool tau = fresh pool (basename tau) tau + +let e_shared pool tau term f = + if is_atomic term then f term else + let x = fresh pool tau in + e_let x term (f (e_var x)) + +let p_shared pool tau term f = + if is_atomic term then f term else + let x = fresh pool tau in + p_let x term (f (e_var x)) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicLib.mli frama-c-20111001+nitrogen+dfsg/src/wp/LogicLib.mli --- frama-c-20110201+carbon+dfsg/src/wp/LogicLib.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicLib.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,9 @@ +(** Logic Path & Regions *) + +open LogicTau +open LogicLang + +val basename : tau -> string +val fresh : pool -> tau -> var +val e_shared : pool -> tau -> term -> (term -> term) -> term +val p_shared : pool -> tau -> term -> (term -> pred) -> pred diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicPretty.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicPretty.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicPretty.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicPretty.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,541 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Logical Language --- ) +( -------------------------------------------------------------------------- ) + +open LogicId +open LogicTau +open LogicRaw +let dkey = "pretty" ( debugging key ) + +type u_printer = Format.formatter -> unit +type 'a printer = Format.formatter -> 'a -> unit +type ('a,'b) printer2 = Format.formatter -> 'a -> 'b -> unit +type 'a fun_printer = Format.formatter -> 'a -> TERM.t list -> unit + +( -------------------------------------------------------------------------- ) +( --- Tools --- ) +( -------------------------------------------------------------------------- ) + +let pp_coma sep pp fmt = function + | [] -> () + | x::xs -> pp fmt x ; List.iter (fun y -> Format.fprintf fmt "%s@ %a" sep pp y) xs + +let pp_assoc nil op pp fmt = function + | [] -> Format.pp_print_string fmt nil + | x::xs -> pp fmt x ; List.iter (fun y -> Format.fprintf fmt "@ %s@ %a" op pp y) xs + +let rec pp_fold_op nil op pp fmt = function + | [] -> Format.pp_print_string fmt nil + | [x] -> pp fmt x + | [x;y] -> Format.fprintf fmt "%a@ %s@ %a" pp x op pp y ; + | x::xs -> Format.fprintf fmt "%a@ %s@ (%a)" pp x op (pp_fold_op nil op pp) xs + +let rec pp_fold_call nil op pp fmt = function + | [] -> Format.pp_print_string fmt nil + | [x] -> pp fmt x + | x::xs -> Format.fprintf fmt "@[<hov 1>%s(%a,@,%a)@]" + op pp x (pp_fold_call nil op pp) xs + +let rec pp_fold_apply nil op pp fmt = function + | [] -> Format.pp_print_string fmt nil + | [x] -> pp fmt x + | x::xs -> Format.fprintf fmt "@[<hov 1>(%s@ %a@ %a)@]" + op pp x (pp_fold_apply nil op pp) xs + +let pp_tuple pp fmt xs = Format.fprintf fmt "@[<hov 1>(%a)@]" (pp_coma "," pp) xs + +let pp_string op fmt = Format.pp_print_string fmt op + +let pp_tuple_call pp fmt f xs = + Format.fprintf fmt "@[<hov 1>%s%a@]" f (pp_tuple pp) xs + +let pp_apply_call pp fmt f = function + | [] -> Format.pp_print_string fmt f + | xs -> + Format.fprintf fmt "@[<hov 1>(%s" f ; + List.iter (fun x -> Format.fprintf fmt "@ %a" pp x) xs ; + Format.fprintf fmt ")@]" + +open VAR +open TERM +open PRED + +let rec apply_labels p = function + | [] -> p | label::labels -> Pnamed(label,apply_labels p labels) + +let rec fold_and acc labels = function + | Pnamed(label,p) -> fold_and acc (label::labels) p + | Pand(p,q) -> fold_and (fold_and acc labels q) labels p + | Ptrue -> acc + | p -> apply_labels p labels :: acc + +let rec fold_hyp acc labels = function + | Pnamed(label,p) -> fold_hyp acc (label::labels) p + | Pand(p,q) -> fold_hyp (fold_hyp acc labels p) labels q + | Ptrue -> acc + | p -> apply_labels p labels :: acc + +let rec fold_or acc labels = function + | Pnamed(label,p) -> fold_or acc (label::labels) p + | Por(p,q) -> fold_or (fold_or acc labels q) labels p + | Pfalse -> acc + | p -> apply_labels p labels :: acc + +let rec fold_implies hs labels = function + | Pimplies(p,q) -> fold_implies (fold_and hs labels p) [] q + | Pnamed(label,p) -> fold_implies hs (label::labels) p + | p -> List.rev hs , apply_labels p labels + +let collect_and p = fold_and [] [] p +let collect_or p = fold_or [] [] p +let collect_implies p = fold_implies [] [] p + +let rec fold_assoc op acc = function + | Tprim( f , ts ) when op = f -> List.fold_left (fold_assoc op) acc ts + | e -> e::acc + +let associative op es = List.fold_left (fold_assoc op) [] es + +let rec collect_labels ls = function + | Pnamed(l,p) -> collect_labels (l::ls) p + | p -> List.rev ls , p + +let rec collect_forall xs = function + | Pforall(x,p) -> collect_forall (x::xs) p + | p -> List.rev xs , p + +let rec collect_exists xs = function + | Pexists(x,p) -> collect_exists (x::xs) p + | p -> List.rev xs , p + +type call_style = + | FunCall + | VFunCall + | ApplyCall + +let pp_call_style style pp_atom pp_free fmt f es = + match style , es with + | (VFunCall|ApplyCall) , [] -> Format.pp_print_string fmt f + | (VFunCall|FunCall) , _ -> pp_tuple_call pp_free fmt f es + | ApplyCall , _ -> pp_apply_call pp_atom fmt f es + +type operator = + | Infix of string + | Prefix of string + | Postfix of string + | Assoc of string string + | Extern of string + | Call of id + +let operator_atomic = function + | Prefix _ | Postfix _ | Call _ | Extern _ -> true + | Infix _ | Assoc _ -> false + +type binder = VAR.t * id + +class engine (space:LogicId.space) = +object(self) + + (* -------------------------------------------------------------------------- ) + ( --- Names --- ) + ( -------------------------------------------------------------------------- ) + + method id x = LogicId.name space x + method pp_id fmt x = Format.pp_print_string fmt (self#id x) + + ( -------------------------------------------------------------------------- ) + ( --- Types --- ) + ( -------------------------------------------------------------------------- ) + + method pp_tau_int = pp_string "int" + method pp_tau_real = pp_string "real" + method pp_tau_bool = pp_string "bool" + method pp_tau_pointer = pp_string "pointer" + method pp_tau_set fmt te = Format.fprintf fmt "{%a..}" self#pp_tau te + method pp_tau_array fmt ta tb = + match ta with + | Integer -> Format.fprintf fmt "@[%a[]@]" self#pp_tau tb + | _ -> Format.fprintf fmt "@[%a[%a]@]" self#pp_tau tb self#pp_tau ta + method pp_tau_record = self#pp_id + method pp_tau_adt fmt a ts = + match ts with + | [] -> self#pp_id fmt a + | [t] -> Format.fprintf fmt "@[%a %a@]" self#pp_tau t self#pp_id a + | ts -> Format.fprintf fmt "@[%a %a@]" (pp_tuple self#pp_tau) ts self#pp_id a + method pp_tau_alpha fmt k = + if 0<= k && k < 26 + then Format.fprintf fmt "'%c" (char_of_int (int_of_char 'a' + k)) + else Format.fprintf fmt "'a%d" k + + method pp_tau fmt = function + | Integer -> self#pp_tau_int fmt + | Real -> self#pp_tau_real fmt + | Boolean -> self#pp_tau_bool fmt + | Pointer -> self#pp_tau_pointer fmt + | Set te -> self#pp_tau_set fmt te + | Array(ta,tb) -> self#pp_tau_array fmt ta tb + | Record r -> self#pp_tau_record fmt r + | ADT(a,ts) -> self#pp_tau_adt fmt a ts + | ALPHA n -> self#pp_tau_alpha fmt n + + ( -------------------------------------------------------------------------- ) + ( --- Variables --- ) + ( -------------------------------------------------------------------------- ) + + val mutable sigma : id VMAP.t = VMAP.empty + val mutable alpha : bool = false + + method bind (xs:VAR.t list) (pp:unit -> unit) = + let mark = LogicId.mark space in + let sigma0 = sigma in + sigma <- List.fold_left + (fun sigma x -> + let xid = LogicId.push space (VAR.basename x) in + VMAP.add x xid sigma) + sigma xs ; + try + pp () ; + sigma <- sigma0 ; + if not alpha then LogicId.unmark space mark ; + with error -> + sigma <- sigma0 ; + if not alpha then LogicId.unmark space mark ; + raise error + + method binder (x:VAR.t) (pp:binder -> unit) = + let xid = LogicId.push space (VAR.basename x) in + try + pp (x,xid) ; + if not alpha then LogicId.pop space xid ; + with error -> + if not alpha then LogicId.pop space xid ; + raise error + + method pp_binder fmt (_,id) = self#pp_id fmt id + method with_binder : 'a. binder -> 'a printer -> 'a printer = + fun (x,xid) pp fmt data -> + let sigma0 = sigma in + sigma <- VMAP.add x xid sigma ; + try + pp fmt data ; + sigma <- sigma0 ; + with error -> + sigma <- sigma0 ; + raise error + + method alpha : 'a. 'a printer -> 'a printer = fun pp fmt data -> + if alpha then pp fmt data + else + let mark = LogicId.mark space in + alpha <- true ; + try + pp fmt data ; + alpha <- false ; + LogicId.unmark space mark ; + with error -> + alpha <- false ; + LogicId.unmark space mark ; + raise error + + method var_id x = VMAP.find x sigma + method pp_var fmt x = + try self#pp_id fmt (VMAP.find x sigma) + with Not_found -> Format.fprintf fmt "?%a" VAR.pretty x + + method pp_vartype fmt x = self#pp_tau fmt (VAR.tau_of_var x) + + ( -------------------------------------------------------------------------- ) + ( --- Terms --- ) + ( -------------------------------------------------------------------------- ) + + method term_call = VFunCall + + method term_atomic = function + | Tint s | Treal s -> not ( String.length s > 0 && s.[0] = '-' ) + | Tvar _ | Tcall _ | Tprim(_,[]) | Ttrue | Tfalse -> true + | Tprim(pi,_) -> operator_atomic (self#term_operator pi) + | Tgetfield _ -> true + | Tsetfield _ -> true + | Taccess _ -> true + | Tupdate _ -> true + | Tif _ -> false + | Tlet _ -> false + + method term_operator = function + | I_add | R_add -> Assoc("0","+") + | I_mul | R_mul -> Assoc("1","") + | I_div -> Infix("div") + | I_mod -> Infix("mod") + | I_sub | R_sub -> Infix("-") + | R_div -> Infix("/") + | I_opp | R_opp -> Prefix("-") + | I_of_R -> Prefix("(int)") + | R_of_I -> Prefix("") + | TERM.L_eq -> Infix("=") + | TERM.L_neq -> Infix("<>") + | TERM.I_lt | TERM.R_lt -> Infix("<") + | TERM.I_leq | TERM.R_leq -> Infix("<=") + | B_not -> Prefix("!") + | B_and -> Assoc("true","&&") + | B_or -> Assoc("false","||") + | I_bnot -> Prefix("~") + | I_band -> Infix("(&)") + | I_bor -> Infix("(|)") + | I_bxor -> Infix("(+)") + | I_lsl -> Infix("(>>)") + | I_lsr -> Infix("(<<)") + + method pp_term_int = Format.pp_print_string + method pp_term_real = Format.pp_print_string + method pp_term_true = pp_string "true" + method pp_term_false = pp_string "false" + + method pp_term_call fmt id es = + pp_call_style self#term_call self#pp_term_atom self#pp_term fmt (self#id id) es + + method pp_term_extern fmt f es = + pp_call_style self#term_call self#pp_term_atom self#pp_term fmt f es + + method pp_term_operator fmt op es = + match op , es with + | Infix s , [a;b] -> Format.fprintf fmt "%a@ %s@ %a" + self#pp_term_atom a s self#pp_term_atom b + | Prefix s , [a] -> Format.fprintf fmt "%s%a" s self#pp_term_atom a + | Postfix s , [a] -> Format.fprintf fmt "%a%s" self#pp_term_atom a s + | (Infix s | Postfix s | Prefix s) , _ -> + Wp_parameters.fatal "Logic:operator(%s) with %d arguments" s + (List.length es) + | Assoc(nil,op) , _ -> pp_assoc nil op self#pp_term_atom fmt es + | Call id , _ -> self#pp_term_call fmt id es + | Extern f , _ -> self#pp_term_extern fmt f es + + method pp_term_primitive fmt pi es = + let op = self#term_operator pi in + let es = match op with Assoc _ -> associative pi es | _ -> es in + self#pp_term_operator fmt op es + + method pp_term_getfield fmt r f = + Format.fprintf fmt "%a.%a" self#pp_term_atom r self#pp_id f.f_name + method pp_term_setfield fmt r f v = + Format.fprintf fmt "@[<hv 2>%a@,.{%a <-@ %a}@]" + self#pp_term_atom r self#pp_id f.f_name self#pp_term v + method pp_term_access fmt r k = + Format.fprintf fmt "%a[%a]" self#pp_term_atom r self#pp_term k + method pp_term_update fmt r k v = + Format.fprintf fmt "@[<hv 2>%a@,[%a <-@ %a]@]" + self#pp_term_atom r self#pp_term k self#pp_term v + + method pp_term_let fmt x a b = + self#binder x + (fun bind -> + Format.fprintf fmt "@[<hv 2>let %a = %a in@ @]%a" + self#pp_binder bind + self#pp_term a + (self#with_binder bind self#pp_term) b) + + method pp_term_cond fmt c a b = + if self#term_atomic a && self#term_atomic b then + Format.fprintf fmt "%a?%a:%a" + self#pp_term_atom c self#pp_term b self#pp_term c + else + Format.fprintf fmt "@[<hv 2>if %a@ then %a@ else %a@]" + self#pp_term c self#pp_term a self#pp_term b + + method pp_term_atom fmt e = + if self#term_atomic e then self#pp_term fmt e + else Format.fprintf fmt "@[<hov 1>(%a)@]" self#pp_term e + + method pp_term fmt = function + | Tvar x -> self#pp_var fmt x + | Ttrue -> self#pp_term_true fmt + | Tfalse -> self#pp_term_false fmt + | Tint z -> self#pp_term_int fmt z + | Treal z -> self#pp_term_real fmt z + | Tcall(f,ts) -> self#pp_term_call fmt f ts + | Tprim(pi,ts) -> self#pp_term_primitive fmt pi ts + | Tgetfield(r,f) -> self#pp_term_getfield fmt r f + | Tsetfield(r,f,v) -> self#pp_term_setfield fmt r f v + | Taccess(r,k) -> self#pp_term_access fmt r k + | Tupdate(r,k,v) -> self#pp_term_update fmt r k v + | Tlet(x,a,b) -> self#pp_term_let fmt x a b + | Tif(c,a,b) -> self#pp_term_cond fmt c a b + + (* -------------------------------------------------------------------------- ) + ( --- Predicates --- ) + ( -------------------------------------------------------------------------- ) + + method pred_atomic = function + | Ptrue | Pfalse | Prel(_,[]) | Pcall _ -> true + | Prel(r,_) -> operator_atomic (self#pred_relation r) + | _ -> false + + method pred_relation = function + | PRED.I_lt | PRED.R_lt -> Infix("<") + | PRED.I_leq | PRED.R_leq -> Infix("<=") + | PRED.L_eq -> Infix("=") + | PRED.L_neq -> Infix("<>") + | B_false -> Prefix "" + | B_true -> Prefix "" + + method pp_pred_true = pp_string "True" + method pp_pred_false = pp_string "False" + method pp_pred_relation fmt rel es = + self#pp_term_operator fmt (self#pred_relation rel) es + method pp_pred_call fmt id ts = + self#pp_term_call fmt id ts + + method pp_pred_and = pp_assoc "True" "/\\" self#pp_pred_atom + method pp_pred_or = pp_assoc "False" "\\/" self#pp_pred_atom + method pp_pred_not fmt p = Format.fprintf fmt "not %a" self#pp_pred_atom p + method pp_pred_iff fmt p q = Format.fprintf fmt "%a@ <->@ %a" + self#pp_pred_atom p self#pp_pred_atom q + + method pp_pred_cond fmt c p q = + Format.fprintf fmt "if %a@ then %a@ else %a" + self#pp_term c self#pp_pred p self#pp_pred q + + method pp_pred_let fmt x a p = + self#binder x + (fun bind -> + Format.fprintf fmt "@[<hv 2>let %a = %a in@ @]%a" + self#pp_binder bind + self#pp_term a + (self#with_binder bind self#pp_pred) p) + + method pp_pred_named fmt labels p = + List.iter + (fun label -> Format.fprintf fmt "%a:@," self#pp_id label) + labels ; + self#pp_pred_atom fmt p + + method pp_pred_implies fmt hs p = + List.iter + (fun h -> Format.fprintf fmt "%a ->@ " self#pp_pred_atom h) hs ; + self#pp_pred fmt p + + method pp_pred_forall fmt xs p = + Format.fprintf fmt "@[<hov 2>forall " ; + self#bind xs + (fun () -> + pp_coma "," + (fun fmt x -> + Format.fprintf fmt "%a:%a" + self#pp_var x self#pp_vartype x) + fmt xs ; + Format.fprintf fmt ".@]@ %a" self#pp_pred p) + + method pp_pred_exists fmt xs p = + Format.fprintf fmt "@[<hov 2>exists " ; + self#bind xs + (fun () -> + pp_coma "," + (fun fmt x -> + Format.fprintf fmt "%a:%a" + self#pp_var x self#pp_vartype x) + fmt xs ; + Format.fprintf fmt ".@]@ %a" self#pp_pred p) + + method pp_pred fmt = function + | Ptrue -> self#pp_pred_true fmt + | Pfalse -> self#pp_pred_false fmt + | Prel(r,es) -> self#pp_pred_relation fmt r es + | Pcall(f,es) -> self#pp_pred_call fmt f es + | Pand _ as p -> self#pp_pred_and fmt (collect_and p) + | Por _ as p -> self#pp_pred_or fmt (collect_or p) + | Pnot p -> self#pp_pred_not fmt p + | Piff(p,q) -> self#pp_pred_iff fmt p q + | Pcond(c,p,q) -> self#pp_pred_cond fmt c p q + | Plet(x,a,p) -> self#pp_pred_let fmt x a p + | Pnamed(label,p) -> + let labels,p = collect_labels [label] p in + self#pp_pred_named fmt labels p + | Pimplies _ as p -> + let hs,p = collect_implies p in + self#pp_pred_implies fmt hs p + | Pforall(x,p) -> + let xs,p = collect_forall [x] p in + self#pp_pred_forall fmt xs p + | Pexists(x,p) -> + let xs,p = collect_exists [x] p in + self#pp_pred_exists fmt xs p + + method pp_pred_atom fmt p = + if self#pred_atomic p then self#pp_pred fmt p + else Format.fprintf fmt "@[<hov 1>(%a)@]" self#pp_pred p + +end + +( -------------------------------------------------------------------------- ) + +( WHY names, for informations + +(* --- PRELUDE.why --- ) + +let neg_int = "neg_int" +let add_int = "add_int" +let sub_int = "sub_int" +let mul_int = "mul_int" +let div_int = "computer_div" +let mod_int = "computer_mod" +let eq_int = "eq" +let ne_int = "neq" +let lt_int = "lt_int" +let le_int = "le_int" + +( --- BOOL.why --- ) + +let bool_not = "bool_not" +let bool_and = "bool_and" +let bool_or = "bool_or" + +( --- INTEGERS.why --- ) + +let eq_int_bool = "eq_int_bool" +let ne_int_bool = "neq_int_bool" +let lt_int_bool = "lt_int_bool" +let le_int_bool = "le_int_bool" + +( --- REAL.why --- ) + +let neg_real = "neg_real" +let add_real = "add_real" +let sub_real = "sub_real" +let mul_real = "mul_real" +let fract_real = "div_real" + +let eq_real_bool = "eq_real_bool" +let ne_real_bool = "neq_real_bool" +let lt_real_bool = "lt_real_bool" +let le_real_bool = "le_real_bool" + +let eq_real = "eq_real" +let ne_real = "neq_real" +let lt_real = "lt_real" +let le_real = "le_real" + +let integer_of_real = "truncate_real_to_int" +let real_of_integer = "real_of_int" + +) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicPretty.mli frama-c-20111001+nitrogen+dfsg/src/wp/LogicPretty.mli --- frama-c-20110201+carbon+dfsg/src/wp/LogicPretty.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicPretty.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,203 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Pretty Printing Library for Logic ) +( -------------------------------------------------------------------------- *) + +open LogicId +open LogicTau +open LogicRaw + +type u_printer = Format.formatter -> unit (** Suitable for [%t] formatter *) +type 'a printer = Format.formatter -> 'a -> unit (** Suitable for [%a] formatter *) +type ('a,'b) printer2 = Format.formatter -> 'a -> 'b -> unit (** Non-formatter usage *) +type 'a fun_printer = Format.formatter -> 'a -> TERM.t list -> unit + +(** {2 Utilities} *) + +val pp_coma : string -> 'a printer -> 'a list printer + (** [pp_coma ","] produces ["x1, x2, ... xn"] *) + +val pp_assoc : string -> string -> 'a printer -> 'a list printer + (** [pp_assoc "0" "+"] produces ["x1 + x2 + ... + xn"] and ["0"] for empty list *) + +val pp_tuple : 'a printer -> 'a list printer + (** [pp_tuple] produces ["(x1, x2, ... )"] and ["()"] for empty list *) + +val pp_string : string -> u_printer + (** The [%t] printer that print the string *) + +val pp_tuple_call : 'a printer -> (string,'a list) printer2 + (** Prints ["f(x1,...,xn)"] and ["f()"] for empty list. *) + +val pp_apply_call : 'a printer -> (string,'a list) printer2 + (** Printts ["(f x1 ... xn)"] of ["f"] for empty list. *) + +val pp_fold_op : string -> string -> 'a printer -> 'a list printer + (** [pp_fold_op "0" "+"] prints ["x+(...(y+z))"] or ["0"]. *) + +val pp_fold_call : string -> string -> 'a printer -> 'a list printer + (** [pp_fold_call "e" "f"] prints ["f(x,f(...,f(y,z)))"] or ["e"]. *) + +val pp_fold_apply : string -> string -> 'a printer -> 'a list printer + (** [pp_fold_apply "e" "f"] prints ["(f x (f...(f y z)))"] or ["e"]. *) + +(** {2 Pretty printer engine} *) + +type binder + +type call_style = + | FunCall (** the [pp_tuple_call] style *) + | VFunCall (** the [pp_tuple_call] style with ["f"] for empty lists *) + | ApplyCall (** the [pp_apply_call] style *) + +type operator = + | Infix of string (** ["x (op) y"] *) + | Prefix of string (** ["x (op)"] *) + | Postfix of string (** ["(op) x"] ) + | Assoc of string string + (** [Assoc(nil,op)] prints [nil] + for empty lists and associatively flatten infix [op] *) + | Extern of string (** call [s] with current call-style *) + | Call of id (** call [id] with current space and call-style *) + +class engine : LogicId.space -> +object + + (** {3 Names} *) + + method id : id -> string + method pp_id : id printer + + (** {3 Types} *) + + method pp_tau_int : u_printer + method pp_tau_real : u_printer + method pp_tau_bool : u_printer + method pp_tau_pointer : u_printer + method pp_tau_set : tau printer + method pp_tau_array : (tau,tau) printer2 + method pp_tau_record : id printer + method pp_tau_adt : (id,tau list) printer2 + method pp_tau_alpha : int printer + method pp_tau : tau printer + + (** {3 Variables} *) + + method alpha : 'a. 'a printer -> 'a printer + (** Runs the printer in an environment with global + alpha-conversion. The global alpha-conversion mode is + reverted after [alpha]. Successive calls to [alpha] keep the + global mode until the first call to [alpha] returns. + Exceptions are correctly tracked. *) + + method bind : 'a. VAR.t list -> (unit -> unit) -> unit + (** [bind x pp] runs [pp] with variable [x] bound to a new + identifier. The identifier is released after [bind] unless + the engine is in global alpha-conversion mode (see [alpha]). + Exceptions are correctly tracked. *) + + method var_id : VAR.t -> id + (** Current identifier associated to a variable. + Raises [Not_found] if unbound. *) + + method pp_var : VAR.t printer + (** Pretty print the variable with its associated identifier. + Prints a debugging name with format ["?<base>#<vid>"] if unbound. *) + + method pp_vartype : VAR.t printer + (** Prints the type of the variable. *) + + method binder : VAR.t -> (binder -> unit) -> unit + (** Allocates an identifier for binder, not-yet linked to the variable. + The bind is release after job. *) + + method pp_binder : binder printer + (** Prints the identifier of the associated variable. *) + + method with_binder : 'a. binder -> 'a printer -> 'a printer + (** Run the printer with the variable locally bound to its identifier. + Exception are correctly tracked. *) + + (** {3 Terms} *) + + method term_call : call_style + method term_atomic : TERM.t -> bool (** Uses [term_operator] *) + method term_operator : TERM.primitive -> operator + + method pp_term_int : string printer + method pp_term_real : string printer + method pp_term_true : u_printer + method pp_term_false : u_printer + method pp_term_extern : string fun_printer + (** Uses [term_call] style *) + method pp_term_call : id fun_printer + (** Uses [term_call] style *) + method pp_term_operator : operator fun_printer + method pp_term_primitive : TERM.primitive fun_printer + (** Uses [term_operator] and [pp_term_operator] + with flattening for associative cases. *) + method pp_term_access : Format.formatter -> TERM.t -> TERM.t -> unit + method pp_term_update : Format.formatter -> TERM.t -> TERM.t -> TERM.t -> unit + method pp_term_getfield : Format.formatter -> TERM.t -> field -> unit + method pp_term_setfield : Format.formatter -> TERM.t -> field -> TERM.t -> unit + method pp_term_cond : Format.formatter -> TERM.t -> TERM.t -> TERM.t -> unit + method pp_term_let : Format.formatter -> VAR.t -> TERM.t -> TERM.t -> unit + + method pp_term_atom : TERM.t printer + (** Prints with [pp_term] with parentheses for only non-atomic terms, + with respect to [term_atomic] method. *) + method pp_term : TERM.t printer + (** Might result in non lexically-atomic print. + Use [pp_term_atom] for safe boxing. *) + + (** {3 Predicates} *) + + method pred_atomic : PRED.t -> bool + method pred_relation : PRED.relation -> operator + + method pp_pred_true : u_printer + method pp_pred_false : u_printer + method pp_pred_relation : PRED.relation fun_printer + (** Uses [pred_operator] and [pp_term_operator] *) + method pp_pred_call : id fun_printer + (** Uses [pp_term_call] *) + method pp_pred_and : PRED.t list printer + method pp_pred_or : PRED.t list printer + method pp_pred_not : PRED.t printer + method pp_pred_iff : (PRED.t,PRED.t) printer2 + method pp_pred_named : (id list,PRED.t) printer2 + method pp_pred_cond : Format.formatter -> TERM.t -> PRED.t -> PRED.t -> unit + method pp_pred_let : Format.formatter -> VAR.t -> TERM.t -> PRED.t -> unit + method pp_pred_forall : (VAR.t list,PRED.t) printer2 + method pp_pred_exists : (VAR.t list,PRED.t) printer2 + method pp_pred_implies : (PRED.t list,PRED.t) printer2 + + method pp_pred_atom : PRED.t printer + (** Prints with [pp_term] with parentheses for only non-atomic terms, + with respect to [pred_atomic] method. *) + method pp_pred : PRED.t printer + (** Might result in non lexically-atomic print. + USe [pp_pred_atom] for safe boxing. *) + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicRaw.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicRaw.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicRaw.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicRaw.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,543 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Logical Language --- ) +( -------------------------------------------------------------------------- ) + +open LogicId +open LogicTau + +let dkey = "logic" ( debugging key ) +let simpl = Wp_parameters.Simpl.get + +( [LC] no file LogicRaw.mli to make internal representation visible ) + +( -------------------------------------------------------------------------- ) +( --- Variables --- ) +( -------------------------------------------------------------------------- ) + +module VAR = +struct + + type t = { + var_vid : int ; + var_base : string ; + var_tau : tau ; + } + + type pool = int ref + + let pool () = ref 0 + + let basename x = x.var_base + let tau_of_var x = x.var_tau + let fresh pool base tau = + incr pool ; { var_base=base ; var_tau=tau ; var_vid= !pool } + let freshen pool x = + incr pool ; { x with var_vid= !pool } + + let different x y = x.var_vid <> y.var_vid + let equal x y = (x.var_vid = y.var_vid) + let compare x y = Pervasives.compare x.var_vid y.var_vid + let hash x = x.var_vid + + let pretty fmt x = Format.fprintf fmt "%s#%d" x.var_base x.var_vid + +end + +module VMAP = Map.Make(VAR) +module VSET = Set.Make(VAR) + +( -------------------------------------------------------------------------- ) +( --- Terms --- ) +( -------------------------------------------------------------------------- ) + +module TERM = +struct + + type primitive = + + | L_eq | L_neq + + ( I operations & comparisons ) + | I_add | I_sub | I_mul | I_div | I_mod | I_opp + | I_lt | I_leq + | I_lsl | I_lsr | I_band | I_bor | I_bxor | I_bnot + + ( R operations & comparisons ) + | R_add | R_sub | R_mul | R_div | R_opp + | R_lt | R_leq + + ( R&I conversions ) + | R_of_I | I_of_R + + ( B operations ) + | B_and | B_or | B_not + + type t = + | Ttrue + | Tfalse + | Tint of string + | Treal of string + | Tprim of primitive t list + | Tcall of id * t list + | Tgetfield of t * field + | Tsetfield of t * field * t + | Taccess of t * t + | Tupdate of t * t * t + | Tif of t * t * t + | Tlet of VAR.t * t * t + | Tvar of VAR.t + + (* Functorial iterator ) + let iter f = function + | Ttrue | Tfalse | Tint _ | Treal _ | Tvar _ -> () + | Tprim(_,ts) | Tcall(_,ts) -> List.iter f ts + | Tgetfield(a,_) -> f a + | Tsetfield(a,_,b) | Taccess(a,b) | Tlet(_,a,b) -> f a ; f b + | Tupdate(a,b,c) | Tif(a,b,c) -> f a ; f b ; f c + + let rec depend ids = function + | Ttrue | Tfalse | Tint _ | Treal _ | Tvar _ -> ids + | Tprim(_,ts) -> List.fold_left depend ids ts + | Tcall(f,ts) -> List.fold_left depend (Iset.add f ids) ts + | Tgetfield(a,f) -> depend (Iset.add f.f_record ids) a + | Tsetfield(a,f,b) -> + depend (depend (Iset.add f.f_record ids) a) b + | Taccess(a,b) | Tlet(_,a,b) -> + depend (depend ids a) b + | Tupdate(a,b,c) | Tif(a,b,c) -> + depend (depend (depend ids a) b) c + + let rec equal e1 e2 = + match e1, e2 with + | Tint x1, Tint x2 -> x1=x2 + | Treal x1, Treal x2 -> x1=x2 + | Ttrue , Ttrue -> true + | Tfalse , Tfalse -> false + | Tcall (f1, args1), Tcall (f2, args2) -> + (LogicId.equal f1 f2) && + (List.length args1 = List.length args2) && + (List.for_all2 equal args1 args2) + | Tprim (f1, args1), Tprim (f2, args2) -> + (f1=f2) && + (List.length args1 = List.length args2) && + (List.for_all2 equal args1 args2) + | Tif (c1, t1, e1), Tif (c2, t2, e2) -> + equal c1 c2 && equal t1 t2 && equal e1 e2 + | Tlet (x,v,t),Tlet(x',v',t') -> + VAR.equal x x' && equal v v' && equal t t' + | Tgetfield (r,f) , Tgetfield(s,g) -> + LogicId.equal f.f_name g.f_name && equal r s + | Tsetfield (r,f,v) , Tsetfield(s,g,w) -> + LogicId.equal f.f_name g.f_name && equal r s && equal v w + | Taccess (t,i) , Taccess (u,j) -> + equal t u && equal i j + | Tupdate (t,i,v), Tupdate(u,j,w) -> + equal t u && equal i j && equal v w + | _ -> false + + let rec different e1 e2 = + match e1 , e2 with + | Tint x1 , Tint x2 -> + not (My_bigint.equal (My_bigint.of_string x1) (My_bigint.of_string x2)) + | _ -> false + + let i_compute f x y = + Tint (My_bigint.to_string (f (My_bigint.of_string x) (My_bigint.of_string y))) + + let i_compare f x y = + if f (My_bigint.compare (My_bigint.of_string x) (My_bigint.of_string y)) then Ttrue else Tfalse + + let rec e_not = function + | Tprim(B_not,[p]) -> p + | Tprim(B_and,[p;q]) -> Tprim(B_or,[e_not p;e_not q]) + | Tprim(B_or,[p;q]) -> Tprim(B_and,[e_not p;e_not q]) + | Tprim(I_lt,[a;b]) -> Tprim(I_leq,[b;a]) + | Tprim(I_leq,[a;b]) -> Tprim(I_lt,[b;a]) + | p -> Tprim(B_not,[p]) + + let e_and a b = + match a,b with + | Ttrue,c | c,Ttrue -> c + | Tfalse,_ | _,Tfalse -> Tfalse + | _ -> Tprim(B_and,[a;b]) + + let e_or a b = + match a,b with + | Tfalse,c | c,Tfalse -> c + | Ttrue,_ | _,Ttrue -> Ttrue + | _ -> Tprim(B_or,[a;b]) + + let e_zero = Tint "0" + let e_int = function 0 -> e_zero | n -> Tint (string_of_int n) + + let rec e_prim f ts = + if not (simpl()) then Tprim(f,ts) else + match f , ts with + | I_opp , [ Tprim(I_opp,[a]) ] -> a + | R_opp , [ Tprim(R_opp,[a]) ] -> a + | I_add , [ Tint a ; Tint b ] -> i_compute My_bigint.add a b + | I_sub , [ Tint a ; Tint b ] -> i_compute My_bigint.sub a b + | I_mul , [ Tint a ; Tint b ] -> i_compute My_bigint.mul a b + | I_add , [ Tint "0" ; x ] -> x + | I_add , [ x ; Tint "0" ] -> x + | I_sub , [ Tint "0" ; x ] -> e_prim I_opp [x] + | I_sub , [ x ; Tint "0" ] -> x + | I_opp , [ Tint a ] -> i_compute My_bigint.sub "0" a + | I_mul , [ Tint "1" ; x ] -> x + | I_mul , [ x ; Tint "1" ] -> x + | I_mul , [ Tint "0" ; _ ] -> e_zero + | I_mul , [ _ ; Tint "0" ] -> e_zero + | I_add , [ b ; Tprim(I_sub,[a;c]) ] when equal b c -> a ; + | I_add , [ Tprim(I_sub,[a;b]) ; c ] when equal b c -> a + | I_sub , [ Tprim(I_add,[a;b]) ; c ] when equal b c -> a + | L_eq , [ Tint a ; Tint b ] -> i_compare (fun r -> r=0) a b + | L_neq , [ Tint a ; Tint b ] -> i_compare (fun r -> r<>0) a b + | I_lt , [ Tint a ; Tint b ] -> i_compare (fun r -> r<0) a b + | L_eq , [a;b] when equal a b -> Ttrue + | L_neq , [a;b] when equal a b -> Tfalse + | I_leq , [ Tint a ; Tint b ] -> i_compare (fun r -> r<=0) a b + | I_of_R , [ Tprim(R_of_I,[a]) ] -> a + | B_not , [p] -> e_not p + | B_and , [a;b] -> e_and a b + | B_or , [a;b] -> e_or a b + | _ -> Tprim(f,ts) + + let e_call f ts = Tcall(f,ts) + + let e_cond c a b = + match c with + | Ttrue -> a + | Tfalse -> b + | Tprim(B_not,[p]) -> Tif(p,b,a) + | _ -> Tif(c,a,b) + + let rec e_getfield r f = + match r with + | Tsetfield(r0,g,v) when simpl () -> if LogicId.equal f.f_name g.f_name then v else e_getfield r0 f + | _ -> Tgetfield(r,f) + + let e_setfield r f v = + match r with + | Tsetfield(r0,g,_) when simpl () && LogicId.equal f.f_name g.f_name -> Tsetfield(r0,f,v) + | _ -> Tsetfield(r,f,v) + + let rec e_access r k = + match r with + | Tupdate(_,k0,v0) when simpl () && equal k k0 -> v0 + | Tupdate(r0,k0,_) when simpl () && different k k0 -> e_access r0 k + | _ -> Taccess(r,k) + + let e_update r k v = + match r with + | Tupdate(r0,k0,_) when simpl () && equal k k0 -> Tupdate(r0,k,v) + | _ -> Tupdate(r,k,v) + + let rec e_hasvar xs = function + | Tvar x -> List.exists (VAR.equal x) xs + | Tcall(_,ts) | Tprim(_,ts) -> List.exists (e_hasvar xs) ts + | Ttrue | Tfalse | Tint _ | Treal _ -> false + | Tif(a,b,c) | Tupdate(a,b,c) -> e_hasvar xs a || e_hasvar xs b || e_hasvar xs c + | Taccess(a,b) | Tsetfield(a,_,b) -> e_hasvar xs a || e_hasvar xs b + | Tgetfield(a,_) -> e_hasvar xs a + | Tlet(x,a,b) -> + e_hasvar xs a || + let ys = List.filter (VAR.different x) xs in + ys <> [] && e_hasvar ys b + +end + +module PRED = +struct + + open TERM + + type relation = + | L_eq | L_neq + | I_lt | I_leq + | R_lt | R_leq + | B_true | B_false + + type t = + | Ptrue + | Pfalse + | Prel of relation TERM.t list + | Pcall of id * TERM.t list + | Pimplies of t * t + | Pand of t * t + | Por of t * t + | Piff of t * t + | Pnot of t + | Pnamed of id * t + | Pcond of TERM.t * t * t + | Plet of VAR.t * TERM.t * t + | Pforall of VAR.t * t + | Pexists of VAR.t * t + + let iter fp ft = function + | Ptrue | Pfalse -> () + | Prel(_,ts) | Pcall(_,ts) -> List.iter ft ts + | Pimplies(a,b) | Pand(a,b) | Por(a,b) | Piff(a,b) -> fp a ; fp b + | Pcond(t,a,b) -> ft t ; fp a ; fp b + | Plet(_,t,a) -> ft t ; fp a + | Pnot a | Pnamed(_,a) | Pforall(_,a) | Pexists(_,a) -> fp a + + let rec depend ids = function + | Ptrue | Pfalse -> ids + | Prel(_,ts) -> List.fold_left TERM.depend ids ts + | Pcall(id,ts) -> List.fold_left TERM.depend (Iset.add id ids) ts + | Pimplies(p,q) | Pand(p,q) | Por(p,q) | Piff(p,q) -> + depend (depend ids p) q + | Pnot p | Pnamed(_,p) | Pforall(_,p) | Pexists(_,p) -> + depend ids p (* names are not declared ) + | Pcond(t,p,q) -> + depend (depend (TERM.depend ids t) p) q + | Plet(_,a,p) -> + depend (TERM.depend ids a) p + + let i_compare f x y = + let r = My_bigint.compare (My_bigint.of_string x) (My_bigint.of_string y) in + if f r then Ptrue else Pfalse + + let p_call p ts = Pcall(p,ts) + + let rec val_of = function Pnamed(_,p) -> val_of p | p -> p + let rec cut pnew = function Pnamed(label,p) -> Pnamed(label,cut pnew p) | _ -> pnew + + let rec p_not p = match val_of p with + | Ptrue -> cut Pfalse p + | Pfalse -> cut Ptrue p + | Pnot p -> p + | Pand(p,q) -> Por(p_not p,p_not q) + | Por(p,q) -> Pand(p_not p,p_not q) + | Pimplies(p,q) -> Pand(p,p_not q) + | Prel( L_eq , [a;b] ) -> Prel( L_neq , [a;b] ) + | Prel( L_neq , [a;b] ) -> Prel( L_eq , [a;b] ) + | Prel( I_lt , [a;b] ) -> Prel( I_leq , [b;a] ) + | Prel( I_leq , [a;b] ) -> Prel( I_lt , [b;a] ) + | Prel( R_lt , [a;b] ) -> Prel( R_leq , [b;a] ) + | Prel( R_leq , [a;b] ) -> Prel( R_lt , [b;a] ) + | Prel( B_true , [a] ) -> Prel( B_false , [a] ) + | Prel( B_false , [a] ) -> Prel( B_true , [a] ) + | Pforall( x , p ) -> Pexists( x , p_not p ) + | Pexists( x , p ) -> Pforall( x , p_not p ) + | _ -> Pnot p + + let p_and p1 p2 = match val_of p1, val_of p2 with + | Ptrue, _ -> p2 + | _, Ptrue -> p1 + | Pfalse,_-> cut Pfalse p1 + | _,Pfalse -> cut Pfalse p2 + | _ -> Pand (p1, p2) + + let p_or p1 p2 = match val_of p1, val_of p2 with + | Ptrue, _ -> cut Ptrue p1 + | _ , Ptrue -> cut Ptrue p2 + | Pfalse ,_ -> p2 + | _ ,Pfalse -> p1 + | _ -> Por (p1,p2) + + let p_xor p1 p2 = match val_of p1, val_of p2 with + | Ptrue , Ptrue -> cut (cut Pfalse p2) p1 + | Ptrue ,_ -> cut Ptrue p1 + | _,Ptrue -> cut Ptrue p2 + | Pfalse , _ -> p2 + | _ , Pfalse -> p1 + | _ -> Pnot(Piff(p1,p2)) + + let p_implies p1 p2 = + match val_of p1, val_of p2 with + | Ptrue, _ -> p2 + | Pfalse, _ -> cut Ptrue p1 + | _, Ptrue -> cut Ptrue p2 + | _ -> Pimplies (p1, p2) + + let p_cond c p1 p2 = match c, val_of p1, val_of p2 with + | _, Ptrue, Ptrue -> cut (cut Ptrue p2) p1 + | _, Pfalse, Pfalse -> cut (cut Pfalse p2) p1 + | Ttrue , _ , _ -> p1 + | Tfalse , _ , _ -> p2 + | Tprim(B_not,[t]) , _ , _ -> Pcond(t,p2,p1) + | _ -> Pcond(c,p1,p2) + + let p_iff p1 p2 = + match val_of p1,val_of p2 with + | Ptrue ,_ -> p2 + | _ ,Ptrue -> p1 + | Pfalse, _ -> p_not p2 + | _ , Pfalse -> p_not p1 + | _ -> Piff (p1,p2) + + let rec p_bool = function + | Ttrue -> Ptrue + | Tfalse -> Pfalse + | Tprim(TERM.L_eq ,[a;b]) -> Prel(L_eq ,[a;b]) + | Tprim(TERM.L_neq,[a;b]) -> Prel(L_neq,[a;b]) + | Tprim(TERM.I_lt ,[a;b]) -> Prel(I_lt ,[a;b]) + | Tprim(TERM.I_leq ,[a;b]) -> Prel(I_leq ,[a;b]) + | Tprim(TERM.R_lt ,[a;b]) -> Prel(R_lt ,[a;b]) + | Tprim(TERM.R_leq ,[a;b]) -> Prel(R_leq ,[a;b]) + | Tprim(B_and,[a;b]) -> p_and (p_bool a) (p_bool b) + | Tprim(B_or,[a;b]) -> p_or (p_bool a) (p_bool b) + | Tprim(B_not,[a]) -> p_not (p_bool a) + | p -> Prel(B_true,[p]) + + let p_prim f ts = + if not (simpl()) then Prel(f,ts) else + match f , ts with + | L_eq , [a;b] when TERM.equal a b -> Ptrue + | L_neq , [a;b] when TERM.equal a b -> Pfalse + | L_eq , [Tint x;Tint y] -> i_compare (fun r -> r=0) x y + | L_neq , [Tint x;Tint y] -> i_compare (fun r -> r<>0) x y + | I_lt , [Tint x;Tint y] -> i_compare (fun r -> r<0) x y + | I_leq , [Tint x;Tint y] -> i_compare (fun r -> r<=0) x y + | B_true , [t] -> p_bool t + | B_false , [t] -> p_not (p_bool t) + | _ -> Prel(f,ts) + + let rec p_hasvar xs = function + | Ptrue | Pfalse -> false + | Pcall(_,ts) | Prel(_,ts) -> List.exists (e_hasvar xs) ts + | Pimplies(p,q) | Pand(p,q) | Por(p,q) | Piff(p,q) -> p_hasvar xs p || p_hasvar xs q + | Pnamed(_,p) | Pnot p -> p_hasvar xs p + | Pcond(a,p,q) -> e_hasvar xs a || p_hasvar xs p || p_hasvar xs q + | Pforall(x,p) | Pexists(x,p) -> + let ys = List.filter (VAR.different x) xs in + ys <> [] && p_hasvar ys p + | Plet(x,a,p) -> + e_hasvar xs a || + let ys = List.filter (VAR.different x) xs in + ys <> [] && p_hasvar ys p + + let p_forall x p = if p_hasvar [x] p then Pforall(x,p) else p + let p_exists x p = if p_hasvar [x] p then Pexists(x,p) else p + let p_let x a p = if p_hasvar [x] p then Plet(x,a,p) else p + +end + +( -------------------------------------------------------------------------- ) +( --- Substitution & Bindings --- ) +( -------------------------------------------------------------------------- ) + +module SUBST = +struct + + open TERM + open PRED + + let is_atomic = function + | Tint _ | Treal _ | Ttrue | Tfalse | Tcall(_,[]) | Tvar _ -> true + | _ -> false + + let rec e_bind ?pool x e t = + let frec = e_bind ?pool x e in + match t with + | Tvar x0 -> if VAR.equal x0 x then e else t + | Ttrue | Tfalse | Tint _ | Treal _ -> t + | Tcall(f,ts) -> Tcall(f,List.map frec ts) + | Tprim(p,ts) -> e_prim p (List.map frec ts) + | Tif(a,b,c) -> e_cond (frec a) (frec b) (frec c) + | Tgetfield(r,f) -> e_getfield (frec r) f + | Tsetfield(r,f,v) -> e_setfield (frec r) f (frec v) + | Taccess(r,k) -> e_access (frec r) (frec k) + | Tupdate(r,k,v) -> e_update (frec r) (frec k) (frec v) + | Tlet(x0,a,b) -> + begin + if e_hasvar [x0] e then + match pool with + | None -> Tlet(x,e,t) + | Some thepool -> + let y = VAR.freshen thepool x in + let b = e_bind ?pool x0 (Tvar y) b in + e_let ?pool y (frec a) (frec b) + else + let b' = if VAR.equal x0 x then b else frec b in + e_let ?pool x0 (frec a) b' + end + + and e_let ?pool x a b = + if e_hasvar [x] b then + if is_atomic a then e_bind ?pool x a b else Tlet(x,a,b) + else b + + let rec p_bind ?pool x e p = + let prec = p_bind ?pool x e in + let erec = e_bind ?pool x e in + match p with + | Ptrue | Pfalse -> p + | Prel(f,ts) -> p_prim f (List.map erec ts) + | Pcall(p,ts) -> Pcall(p,List.map erec ts) + | Pimplies(p,q) -> p_implies (prec p) (prec q) + | Pcond(a,p,q) -> p_cond (erec a) (prec p) (prec q) + | Pand(p,q) -> p_and (prec p) (prec q) + | Por(p,q) -> p_or (prec p) (prec q) + | Piff(p,q) -> p_iff (prec p) (prec q) + | Pnot(p) -> p_not (prec p) + | Pnamed(a,p) -> Pnamed(a,prec p) + | Pforall(x0,p) as p0 -> + begin + if VAR.equal x x0 then p0 + else if e_hasvar [x0] e then + match pool with + | None -> Plet(x,e,p0) + | Some thepool -> + let y = VAR.freshen thepool x in + let py = p_bind ?pool x0 (Tvar y) p in + PRED.p_forall y (prec py) + else PRED.p_forall x0 (prec p) + end + | Pexists(x0,p) as p0 -> + begin + if VAR.equal x x0 then p0 + else if e_hasvar [x0] e then + match pool with + | None -> Plet(x,e,p0) + | Some thepool -> + let y = VAR.freshen thepool x in + let py = p_bind ?pool x0 (Tvar y) p in + PRED.p_exists y (prec py) + else PRED.p_exists x0 (prec p) + end + | Plet(x0,t,p) as p0 -> + begin + if e_hasvar [x0] e then + match pool with + | None -> Plet(x,e,p0) + | Some thepool -> + let y = VAR.freshen thepool x in + let py = p_bind ?pool x0 (Tvar y) p in + p_let ?pool y (erec t) (prec py) + else + let p' = if VAR.equal x0 x then p else prec p in + p_let ?pool x0 (erec t) p' + end + + and p_let ?pool x a p = + if p_hasvar [x] p then + if is_atomic a then p_bind ?pool x a p else Plet(x,a,p) + else p + +end + +( -------------------------------------------------------------------------- *) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicTau.ml frama-c-20111001+nitrogen+dfsg/src/wp/LogicTau.ml --- frama-c-20110201+carbon+dfsg/src/wp/LogicTau.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicTau.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,105 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Logical Language --- ) +( -------------------------------------------------------------------------- ) + +open LogicId + +( -------------------------------------------------------------------------- ) +( --- Types --- ) +( -------------------------------------------------------------------------- ) + +type tau = + | Integer + | Real + | Boolean + | Pointer + | Set of tau + | Array of tau tau + | Record of id + | ADT of id * tau list + | ALPHA of int + +type field = { + f_record : id ; + f_name : id ; + f_type : tau ; +} + +let rec compare_tau t1 t2 = + match t1 , t2 with + + | Integer , Integer -> 0 + | Integer , _ -> (-1) + | _ , Integer -> 1 + + | Real , Real -> 0 + | Real , _ -> (-1) + | _ , Real -> 1 + + | Boolean , Boolean -> 0 + | Boolean , _ -> (-1) + | _ , Boolean -> 1 + + | Pointer , Pointer -> 0 + | Pointer , _ -> (-1) + | _ , Pointer -> 1 + + | ALPHA k , ALPHA k' -> Pervasives.compare k k' + | ALPHA _ , _ -> (-1) + | _ , ALPHA _ -> 1 + + | Set ta , Set tb -> compare_tau ta tb + | Set _ , _ -> (-1) + | _ , Set _ -> 1 + + | Array(ta,tb) , Array(ta',tb') -> compare_sig [ta;tb] [ta';tb'] + | Array _ , _ -> (-1) + | _ , Array _ -> 1 + + | Record ra , Record rb -> LogicId.compare ra rb + | Record _ , _ -> (-1) + | _ , Record _ -> 1 + + | ADT(a,ps) , ADT(b,qs) -> + let cid = LogicId.compare a b in + if cid<>0 then cid else compare_sig ps qs + +and compare_sig ps qs = + match ps , qs with + | [] , [] -> 0 + | [] , _ -> (-1) + | _ , [] -> 1 + | t1::ps , t2::qs -> + let ct = compare_tau t1 t2 in + if ct<>0 then ct else compare_sig ps qs + +let compare_field f1 f2 = LogicId.compare f1.f_name f2.f_name + +let rec depend ids = function + | Integer | Real | Boolean | Pointer | ALPHA _ -> ids + | Set te -> depend ids te + | Array(ta,tb) -> depend (depend ids ta) tb + | Record r -> Iset.add r ids + | ADT(a,ts) -> List.fold_left depend (Iset.add a ids) ts diff -Nru frama-c-20110201+carbon+dfsg/src/wp/LogicTau.mli frama-c-20111001+nitrogen+dfsg/src/wp/LogicTau.mli --- frama-c-20110201+carbon+dfsg/src/wp/LogicTau.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/LogicTau.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,54 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Logical Language ) +( -------------------------------------------------------------------------- ) + +open LogicId + +( -------------------------------------------------------------------------- *) +(** {2 Types} ) +( -------------------------------------------------------------------------- *) + +type tau = + | Integer (** Mathematical Z numbers *) + | Real (** Mathematical R numbers *) + | Boolean (** Finite set [{true,false}] *) + | Pointer (** Pointer datatype in current model (see LogicDef.register) *) + | Set of tau (** [Set t]: Mathematical sets with elements of type [t] ) + | Array of tau tau (** [Array(ta,tb)]: Total functions from [ta] to [tb] *) + | Record of id (** Tuples [(fi,vi)] with [vi] of type [fi.ftype] and [fi] in [rfields] ) + | ADT of id tau list (** Polymorphic instance of datatype [a] with parameters [ti] *) + | ALPHA of int (** [i-th] parameter of a polymorphic type in its definition. Starts with [0]. *) + +type field = { + f_record : id ; + f_name : id ; + f_type : tau ; +} + +val compare_tau : tau -> tau -> int +val compare_sig : tau list -> tau list -> int +val compare_field : field -> field -> int + +val depend : Iset.t -> tau -> Iset.t diff -Nru frama-c-20110201+carbon+dfsg/src/wp/Makefile.in frama-c-20111001+nitrogen+dfsg/src/wp/Makefile.in --- frama-c-20110201+carbon+dfsg/src/wp/Makefile.in 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/Makefile.in 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,159 @@ +########################################################################## +# # +# This file is part of WP plug-in of Frama-C. # +# # +# Copyright (C) 2007-2011 # +# CEA (Commissariat a l'�nergie atomique et aux �nergies # +# alternatives) # +# # +# you can redistribute it and/or modify it under the terms of the GNU # +# Lesser General Public License as published by the Free Software # +# Foundation, version 2.1. # +# # +# It 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 Lesser General Public License for more details. # +# # +# See the GNU Lesser General Public License version 2.1 # +# for more details (enclosed in the file licenses/LGPLv2.1). # +# # +########################################################################## + +## TODO: bug in Makefile.in with generated wp_version.ml +.PHONY: version + +## WP_KERNEL=Carbon-20110201+dev +## WP_VERSION=0.3+dev + +# Do not use ?= to initialize both below variables +# (fixed efficiency issue, see GNU Make manual, Section 8.11) +ifndef FRAMAC_SHARE +FRAMAC_SHARE :=$(shell frama-c -journal-disable -print-path) +endif +ifndef FRAMAC_LIBDIR +FRAMAC_LIBDIR :=$(shell frama-c -journal-disable -print-libpath) +endif +PLUGIN_DIR ?=. + +ALTERGO_VERSION=@ALTERGO_VERSION@ +WHY=@WHY@ +COQ=@COQ@ +ALTERGO=@ALTERGO@ +WHYDP=@WHYDP@ + +include $(FRAMAC_SHARE)/Makefile.config + +MODELS:= share/wp.v \ + share/hoare_model.v \ + share/hoare_model.why \ + share/hoare_ergo.why \ + share/store_model.v \ + share/store_model.why \ + share/store_ergo.why \ + share/runtime_model.v \ + share/runtime_model.why \ + share/runtime_ergo.why \ + +# Extension of the GUI for wp is compilable +# only if gnomecanvas is available +ifeq ($(HAS_GNOMECANVAS),yes) +PLUGIN_GUI_CMO:= po_navigator wp_gui +PLUGIN_UNDOC:= +else +PLUGIN_UNDOC:= po_navigator.ml wp_gui.ml +endif + +PLUGIN_ENABLE:=@ENABLE_WP@ +PLUGIN_DYNAMIC:=@DYNAMIC_WP@ +PLUGIN_NAME:=Wp +PLUGIN_CMO:= \ + wprop \ + wp_parameters wp_error \ + ctypes clabels \ + cil2cfg normAtLabels \ + wpPropId wpStrategy wpFroms wpAnnot \ + script proof \ + wpo prover \ + variables_analysis datalib \ + fol fol_let fol_decl fol_pretty \ + data_mem \ + mint_natural mfloat_natural \ + funvar_mem runtime_mem store_mem hoare_mem \ + fol_cc fol_eqs fol_eval fol_norm \ + fol_split fol_why fol_ergo kreal fol_coq \ + fol_formula \ + LogicId LogicTau LogicRaw LogicPretty LogicLang \ + LogicLib LogicHavoc LogicDef \ + ACSL \ + translate_expr \ + translate_prop \ + calculus cfgpropid \ + cfgWeakestPrecondition \ + cfgProof \ + register + +PLUGIN_CMI:= \ + mcfg formula \ + mint mfloat mvalues mlogic mwp + +PLUGIN_GENERATED:= $(PLUGIN_DIR)/script.ml +# $(PLUGIN_DIR)/wp_version.ml + +PLUGIN_UNDOC+= fol_qed.mli fol_qed.ml +PLUGIN_INTRO:=$(FRAMAC_SRC)/doc/code/intro_wp.txt +PLUGIN_HAS_MLI:=yes +PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE) +PLUGIN_DISTRIB_EXTERNAL:= Makefile.in configure.ac configure $(MODELS) + +ifeq ("$(OCAMLGRAPH_LOCAL)","") +OFLAGS+=-I +ocamlgraph +BFLAGS+=-I +ocamlgraph +endif + +# -------------------------------------------------------------------------- +# --- Tests --- +# -------------------------------------------------------------------------- + +PLUGIN_TESTS_DIRS:= wp wp_plugin wp_acsl wp_store wp_hoare wp_runtime wp_bts wp_engine +#PLUGIN_NO_TESTS:=no +#PLUGIN_NO_DEFAULT_TEST:=yes + +# -------------------------------------------------------------------------- +# --- Dynamic Plugin --- +# -------------------------------------------------------------------------- + +include $(FRAMAC_SHARE)/Makefile.dynamic + +# Regenerating the Makefile on need + +ifeq ("$(FRAMAC_INTERNAL)","yes") +CONFIG_STATUS_DIR=$(FRAMAC_SRC) +else +CONFIG_STATUS_DIR=. +endif + +## Bug with Makefile.in : the wp_version.ml is systematically re-generated +## [BM] 04/22/2011 seems to be fixed +# $(Wp_DIR)/wp_version.ml: $(Wp_DIR)/Makefile.in +# @echo "Generate wp_version.ml" +# @echo 'let kernel = "$(WP_KERNEL)"' > $@ +# @echo 'let version = "$(WP_VERSION)"' >> $@ +# @headache -c headers/headache_config.txt -h headers/CEA_LGPL $@ + +## Removing dependency to headache. +# @headache -c headers/headache_config.txt -h headers/CEA_LGPL $@ + +$(Wp_DIR)/Makefile: $(Wp_DIR)/Makefile.in $(CONFIG_STATUS_DIR)/config.status + @cd $(CONFIG_STATUS_DIR) && ./config.status + @make depend + +install:: + $(MKDIR) $(FRAMAC_DATADIR)/wp + $(CP) $(addprefix $(Wp_DIR)/,$(MODELS)) $(FRAMAC_DATADIR)/wp + +# -------------------------------------------------------------------------- +# --- WP Release Stuff (CEA-LIST Only) +# -------------------------------------------------------------------------- +sinclude MakeDistrib +# -------------------------------------------------------------------------- diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mcfg.mli frama-c-20111001+nitrogen+dfsg/src/wp/mcfg.mli --- frama-c-20110201+carbon+dfsg/src/wp/mcfg.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mcfg.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,131 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types + +type scope = + | SC_Global + | SC_Function_in (* Just before the pre-state ) + | SC_Function_frame ( Just after the introduction of formals ) + | SC_Function_out ( Post-state *) + | SC_Block_in + | SC_Block_out + +type assigns_method = + | NoAssigns + | NormalAssigns + | EffectAssigns + +module type Export = +sig + type pred + type decl + val export_section : Format.formatter -> string -> unit + val export_goal : Format.formatter -> string -> pred -> unit + val export_decl : Format.formatter -> decl -> unit +end + +module type Splitter = +sig + type pred + val simplify : pred -> pred + val split : assigns_method -> pred -> pred Bag.t +end + +(** + * This is what is really needed to propagate something through the CFG. + * Usually, the propagated thing should be a predicate, + * but it can be more sophisticated like lists of predicates, + * or maybe a structure to keep hypotheses and goals separated. + * Moreover, proof obligations may also need to be handeled. + ) +module type S = sig + + type t_prop + val pretty : Format.formatter -> t_prop -> unit + val merge : t_prop -> t_prop -> t_prop + val empty : t_prop + + type t_env + + ( optionally init env with user logic variables *) + val new_env : ?lvars:Cil_types.logic_var list -> kernel_function -> t_env + + val add_axiom : WpPropId.prop_id -> string -> logic_label list -> predicate named -> unit + val add_hyp : t_env -> WpPropId.pred_info -> t_prop -> t_prop + val add_goal : t_env -> WpPropId.pred_info -> t_prop -> t_prop + + val add_assigns : t_env -> WpPropId.assigns_info -> t_prop -> t_prop + + (** [use_assigns env hid kind assgn goal] performs the havoc on the goal. + * [hid] should be [None] iff [assgn] is [WritesAny], + * and tied to the corresponding identified_property otherwise.) + val use_assigns : t_env -> WpPropId.prop_id option -> + WpPropId.assigns_desc -> t_prop -> t_prop + + val assigns_method : unit -> assigns_method + + val label : t_env -> Clabels.c_label -> t_prop -> t_prop + val assign : t_env -> lval -> exp -> t_prop -> t_prop + val return : t_env -> exp option -> t_prop -> t_prop + val test : t_env -> exp -> t_prop -> t_prop -> t_prop + val switch : t_env -> exp -> (exp list t_prop) list -> t_prop -> t_prop + val init_value : t_env -> lval -> typ -> exp option -> t_prop -> t_prop + (** init_value env lv t v_opt wp: + put value of type t (or default if None) in lv *) + val init_range : t_env -> lval -> typ -> int64 -> int64 -> t_prop -> t_prop + (** init_range env lv t_elt a b wp : + put default values of type t_elt in lv[k] with a <= k t_prop -> t_prop + + ( -------------------------------------------------------------------------- ) + ( --- Call Rules --- ) + ( -------------------------------------------------------------------------- ) + + val call_goal_precond : t_env -> stmt -> + kernel_function -> exp list -> + pre: WpPropId.pred_info list -> + t_prop -> t_prop + + val call : t_env -> stmt -> + lval option -> kernel_function -> exp list -> + pre: WpPropId.pred_info list -> + post: WpPropId.pred_info list -> + pexit: WpPropId.pred_info list -> + assigns: identified_term assigns -> + p_post: t_prop -> + p_exit: t_prop -> + t_prop + + ( -------------------------------------------------------------------------- ) + ( --- SCOPING RULES --- ) + ( -------------------------------------------------------------------------- *) + + val scope : t_env -> varinfo list -> scope -> t_prop -> t_prop + + (** build [p => alpha(p)] for functional dependencies verification. *) + val build_prop_of_from : t_env -> WpPropId.pred_info list -> t_prop -> t_prop + + val close : t_env -> t_prop -> t_prop + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mfloat.mli frama-c-20111001+nitrogen+dfsg/src/wp/mfloat.mli --- frama-c-20110201+carbon+dfsg/src/wp/mfloat.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mfloat.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,41 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Float and Real Model ) +( -------------------------------------------------------------------------- *) + +open Formula +open Ctypes + +module type S = +sig + + module F : Formula.S + + (** {2 Float Operators} *) + + val f_neg : c_float -> F.real -> F.real + val f_op : c_float -> real_op -> F.real -> F.real -> F.real + val f_cmp : c_float -> cmp_op -> F.real -> F.real -> F.boolean + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mfloat_natural.ml frama-c-20111001+nitrogen+dfsg/src/wp/mfloat_natural.ml --- frama-c-20110201+carbon+dfsg/src/wp/mfloat_natural.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mfloat_natural.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,54 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Basic Real Model --- ) +( -------------------------------------------------------------------------- ) + +open Formula + +module Create (F:Formula.S) : (Mfloat.S with module F = F) = +struct + + module F = F + + let tau_of_cfloat _ = Real + + let format_of_cfloat _ = F.unwrap (F.e_call "real_format" []) + + (Float cst ) + + let f_float _f k = F.e_rcst k + + ( arithmetic operations on R in why ) + + let f_neg _i = F.e_rneg + let f_op _i = F.e_rop + let f_cmp _i = F.e_rcmp + + ( conversion on R in why *) + + let f_convert _t1 _t2 e = e + let real_of_float _te e = e + let float_of_real _t1 e = e + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mint.mli frama-c-20111001+nitrogen+dfsg/src/wp/mint.mli --- frama-c-20110201+carbon+dfsg/src/wp/mint.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mint.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,50 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Integer Model ) +( -------------------------------------------------------------------------- *) + +open Formula +open Ctypes + +module type S = +sig + + module F : Formula.S + + (** {2 Integer Operators} *) + + val i_neg : c_int -> F.integer -> F.integer + val i_op : c_int -> int_op -> F.integer -> F.integer -> F.integer + val i_cmp : c_int -> cmp_op -> F.integer -> F.integer -> F.boolean + + (** {2 Bitwise Operators} *) + + val bits_not : c_int -> F.integer -> F.integer + val bits_and : c_int -> F.integer -> F.integer -> F.integer + val bits_or : c_int -> F.integer -> F.integer -> F.integer + val bits_xor : c_int -> F.integer -> F.integer -> F.integer + val bits_lshift : c_int -> F.integer -> F.integer -> F.integer + val bits_rshift : c_int -> F.integer -> F.integer -> F.integer + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mint_natural.ml frama-c-20111001+nitrogen+dfsg/src/wp/mint_natural.ml --- frama-c-20110201+carbon+dfsg/src/wp/mint_natural.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mint_natural.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,70 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Basic Implementation (Arithmetics is mapped to Z) --- ) +( -------------------------------------------------------------------------- ) + +open Ctypes +open Formula + +module Create (F:Formula.S) : (Mint.S with module F = F) = +struct + + module F = F + + ( integer cst ) + let i_int _i k = F.e_icst k + + ( arithmetic operations on Z in why ) + + let i_neg i e = + let k = F.e_ineg e in + if (Ctypes.signed i) then k else F.modulo i k + let i_op _i iop e1 e2 = F.e_iop iop e1 e2 + let i_cmp _i cmp e1 e2 = (F.e_icmp cmp e1 e2) + + ( bitwise operations on Z in why ) + + let sizeof i = F.e_int (Ctypes.i_sizeof i) + let signess i = if (Ctypes.signed i) then F.e_true else F.e_false + + let bits_not _ = F.e_app1 "int_not" + let bits_and _ = F.e_app2 "int_and" + let bits_or _ = F.e_app2 "int_or" + let bits_xor _ = F.e_app2 "int_xor" + let bits_lshift _ = F.e_app2 "int_lsh" + let bits_rshift i = + F.e_app2 (if (Ctypes.signed i) then "int_rshs" else "int_rshu") + + ( integers conversions ) + + let i_convert t1 t2 e = + if Ctypes.sub_c_int t1 t2 then e else F.modulo t2 e + + let integer_of_int _ e = e + ( Z-representatives live in the correct range. ) + + let int_of_integer _ e = e + ( Conversions are never necessary for this model, since no overflow are allowed. *) + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mlogic.mli frama-c-20111001+nitrogen+dfsg/src/wp/mlogic.mli --- frama-c-20110201+carbon+dfsg/src/wp/mlogic.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mlogic.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,94 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Model for the interpretation of ACSL/C ) +( -------------------------------------------------------------------------- *) + +open Ctypes +open Clabels +open Formula +open Cil_types + +module type S = +sig + + (** {2 Term Values} *) + + include Mvalues.S + + val lvar : mem -> logic_var -> F.var-> loc + (** [lvar m lv p] returns a location associated to the + location variable [lv] with variable root name [x]. + [x] for all model except in funvar. *) + + val inner_loc : loc -> F.abstract + (** [inner_loc l] returns the location corresponding + to [l] in the inner memory model in funvar. + Not implemented in other models. *) + + + (** {2 Pointers} *) + + val base_address : mem -> loc -> loc + (** [base_address m l] return the [base address] of [l].*) + + val block_length : mem -> loc -> F.integer + (** [block_length m l t] return the [block_length] + of the location [l]. *) + + (** {2 Validity }*) + + val valid : mem -> loc F.assigned -> F.pred + + (** {2 Separation} *) + + val separated : mem -> loc F.assigned -> loc F.assigned -> F.pred + + (** {2 User-defined Predicates} ) + + type formal + val pp_formal : Format.formatter -> ( formal logic_var ) -> unit + + val userdef_ref_has_cvar : logic_var -> bool + (** [userdef_ref_has_cvar p] tests if the by reference + logic formal parameter [p] needs a C addresses.*) + + val userdef_is_ref_param : logic_var -> bool + (** [userdef_ref_param p] tests if [p] is a by reference logic + formal parameter.) + + val userdef_ref_signature : mem -> ( F.var logic_var * formal ) list + val userdef_ref_apply : mem -> formal -> loc -> value + + type closure + val pp_closure : Format.formatter -> closure -> unit + + val userdef_mem_signature : mem -> ( F.var * closure ) list + val userdef_mem_apply : mem -> closure -> F.abstract + +end +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mvalues.mli frama-c-20111001+nitrogen+dfsg/src/wp/mvalues.mli --- frama-c-20110201+carbon+dfsg/src/wp/mvalues.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mvalues.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,193 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Memory Model Signature ) +( -------------------------------------------------------------------------- *) + +open Ctypes +open Clabels +open Formula +open Cil_types + +module type Model = +sig + + module F : Formula.S + module A : Mint.S with module F = F + module R : Mfloat.S with module F = F + + type loc + + val tau_of_loc :tau + + val term_of_loc : loc -> F.abstract + val loc_of_term : c_object -> F.abstract -> loc + + + (** {2 Loc arithmetics} *) + + val equal_loc_bool : loc -> loc -> F.boolean + (** [equal_loc_bool p q] is the boolean that is true when + locs [p] and [q], that points to elements of type [ty], + are equal. Returns a term of type [bool]. *) + + val lt_loc_bool : loc -> loc -> F.boolean + (** [lt_loc_bool p q] is the less than comparison + of locs [p] and [q], that points to elements of type [ty], + ie. [p<q]. Returns a term of type [boolean]. + *) + + val le_loc_bool : loc -> loc -> F.boolean + (** [le_loc_bool p q] is the less than or equal comparison + of locs [p] and [q], that points to elements of type [ty], + ie. [p<=q]. Returns a term of type [boolean]. + *) + + val lt_loc : loc -> loc -> F.pred + (** [lt_loc p q] is the less than comparison + of locs [p] and [q], that points to elements of type [ty], + ie. [p<q]. + *) + + val le_loc : loc -> loc -> F.pred + (** [le_loc p q] is the less than or equal comparison + of locs [p] and [q], that points to elements of type [ty], + ie. [p<=q]. + *) + + val equal_loc: loc -> loc -> F.pred + + val minus_loc : loc -> loc -> F.integer + (** [minus_loc ty p q] is the arithmetics difference of + locs [p] and [q], that points to elements of type [ty], + ie. [p-q]. Returns a term of type [integer]. *) + + val is_null : loc -> F.boolean + (** Take a term representing an [address] and returns a + term of type [bool]. *) + + (** {2 Special locations} *) + + val null : loc + (** [null] return the special location of the memory model designing + the null loc. *) + + (** + * [cast_loc_to_int t p c_int] : + * cast [loc] if type [t] into a term of type [c_int] + ) + + val cast_loc_to_int : Cil_types.typ -> loc -> Ctypes.c_int -> F.integer + val cast_int_to_loc : Ctypes.c_int -> F.integer -> Cil_types.typ -> loc + + val pp_loc : Format.formatter -> loc -> unit + +end + +module type Values = +sig + + include Model + + ( The internal representation of an ACSL value ) + type value = + | V_int of Ctypes.c_int * F.integer + | V_float of Ctypes.c_float * F.real + | V_pointer of Ctypes.c_object * loc + | V_record of compinfo * F.record + | V_union of compinfo * F.urecord + | V_array of arrayinfo * F.array + + val pp_value : Format.formatter -> value -> unit + + (** Conversion between internal representation of ACSL value and FOL term ) + + + val equal : c_object -> F.abstract -> F.abstract -> F.pred + val eq_array : arrayinfo -> F.array -> F.array -> F.pred + val eq_record : compinfo -> F.record -> F.record -> F.pred + + val logic_of_value : value -> F.abstract + val value_of_logic : c_object -> F.abstract -> value + val tau_of_object : c_object -> tau + val tau_of_object_array : c_object -> int -> tau + val tau_of_logic_type : Cil_types.logic_type -> tau + val pp_tau: Format.formatter -> tau -> unit + val symb_is_init : c_object -> string option + val symb_is_init_range : c_object -> string option + +end + +module type Data = +sig + + include Values + + type m_of_mem + val tau_of_mem : tau + val forall_loc : F.pool -> F.var list loc + + val index : loc -> c_object -> F.integer -> loc + val field : loc -> fieldinfo -> loc + + val load_mem : m_of_mem F.term -> c_object -> loc -> value + val store_mem : m_of_mem F.term -> c_object -> loc -> value -> m_of_mem F.term + +end + +module type S = +sig + + include Values + module L:Formula.Logic with module F = F + + (** {2 Memory, Field and Array access} *) + + type mem + + val mem : unit -> mem + + val global : varinfo -> unit + + val cvar : mem -> varinfo -> loc + + val shift : loc -> c_object -> F.integer -> loc + (** [shift ptr tau k] computes the location + of [ptr+k], where [ptr] is a pointer to a value of type [tau]. *) + + val index : loc -> c_object -> F.integer -> loc + (** [index tab tau k] computes the location + of [tab[k]], where [tab] is an array with elements of type [tau]. *) + + val startof : loc -> c_object -> loc + (** [startof] return a pointer to the first element of an array *) + + val field : loc -> fieldinfo -> loc + + val load : mem -> c_object -> loc -> value + + val cast_loc_to_loc : typ -> typ -> loc -> loc + (** [cast_loc_to_loc t1 t2 l] returns the casted location of type [t2] + from the location [l] of type [t1] *) + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/mwp.mli frama-c-20111001+nitrogen+dfsg/src/wp/mwp.mli --- frama-c-20110201+carbon+dfsg/src/wp/mwp.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/mwp.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,125 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Model for the interpretation of ACSL/C ) +( -------------------------------------------------------------------------- *) + +open Ctypes +open Clabels +open Formula +open Cil_types + +module type Export = +sig + type pred + type decl + val export_goal : Format.formatter -> string -> pred -> unit + val export_decl : Format.formatter -> decl -> unit +end + +module type S = +sig + + include Mlogic.S + + (** + [update m h p] binds free variables in [p] representing + the state [m] to the current memory [h]. + *) + + val update : at:mem -> here:mem -> F.pred -> F.pred + + (** [quantify_at_label m p] quantifies the free variables in [p] + representing the memort state [m]. + + It generalize the goal up-to the state [m]. + *) + + val quantify : mem -> F.pred -> F.pred + + (** [subst_lval frame l te v p] binds in [p] the free variables + representing the value at location [l] in the current memory to + the actual value [v]. + + It updates the memory-map [frame] such that now the current memory in [p] + has been updated by storing [v] at [l]. + *) + + val subst_lval : mem -> Ctypes.c_object -> loc -> value -> F.pred -> F.pred + + (** Binds the free variables in + the wp representing the memory locations that live in [zone]. + Actually, subst_havoc must no do the substitution it-self to avoid + any variable capture un region. Rather, [subst_havoc] should returns the + list of substitutions to be applied modulo alpha-conversion. + *) + val subst_havoc : mem -> loc F.assigned -> F.havoc list + + (** {2 Assigns} *) + + (** [assigns_goal M1 region M2] returns a predicates + establishing the assigns clause [region] with dependencies [depends]. + - [M1] is the memory {i before} of the execution of the assigning statement. + - [M2] is the memory {i after} of the execution of the assigning statement. + *) + + val assigns_goal : + mem -> + loc F.assigned list -> + mem -> + F.pred + + val assigns_supported : bool + + (** {2 Assigns with Zones} *) + + type m_dzone + type dzone = m_dzone F.term + val tau_of_dzone : tau + + val dzone_assigned : mem -> loc F.assigned -> dzone + val dzone_subset : dzone -> dzone -> F.pred + val dzone_union : dzone -> dzone -> dzone + val dzone_empty : unit -> dzone + + val effect_supported : bool + + + + val global_scope : mem -> F.pred -> F.pred + + (** [local_scope m l] transforms the predicate [p] at the + enter-point of a block or function that + declares the local variables in the list. It is time to add + hypotheses about those local variables. ) + val local_scope : mem -> Cil_types.varinfo list -> Mcfg.scope -> F.pred -> F.pred + +end + + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/normAtLabels.ml frama-c-20111001+nitrogen+dfsg/src/wp/normAtLabels.ml --- frama-c-20110201+carbon+dfsg/src/wp/normAtLabels.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/normAtLabels.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,227 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +open Cil_types + +type label_mapping = Cil_types.logic_label -> Cil_types.logic_label + + +( push the Tat down to the 'data' operations. +* This can be useful in cases like \at (x + \at(y, Ly), Lx) because +* it gives \at(x, Lx) + \at(y, Ly) so there is no more \at imbrications. + * Also try to "normalize" label : + * - remove Here because its meaning change when propagating, + * - remove Old because its meaning depend on where it comes from. +* ) +class norm_at label_map = object(self) + inherit Visitor.generic_frama_c_visitor (Project.current()) (Cil.copy_visit()) + + val mutable current_label = None + + method private change_label label = + let label = label_map label in + let old_label = current_label in + current_label <- Some label; old_label + + method private restore_term old_label x = + current_label <- old_label; + let x = match x.term_node with + | Ttypeof x -> ( Ttypeof is used as a dummy unary construct ) x + | _ -> assert false + in x + + method private restore_pred old_label x = + current_label <- old_label; + let x = match x.content with + | Pnot x -> ( Pnot is used as a dummy unary construct ) x + | _ -> assert false + in x + + + method vterm t = + match t.term_node with + | Tat (t, l) -> + let old_label = self#change_label l in + let new_t = {t with term_node = Ttypeof t} in + Cil.ChangeDoChildrenPost (new_t, self#restore_term old_label) + | TAddrOf (h, _) | TLval (h, _) | TStartOf (h, _) -> + let old_label = current_label in + let at_label = match h with + | TResult _ -> Some Logic_const.post_label + | _ -> old_label + in + current_label <- None; + let post t = + current_label <- old_label; + match at_label with + | Some label -> {t with term_node = Tat (t, label)} + | None -> t + in Cil.ChangeDoChildrenPost (t, post) + | Tapp _ -> + let post = function + | {term_node=Tapp(predicate,labels,args)} as t -> + let new_labels = + List.map + (fun (logic_lab, stmt_lab) -> logic_lab, label_map stmt_lab) + labels + in { t with term_node=Tapp(predicate,new_labels,args) } + | _ -> assert false + in + Cil.ChangeDoChildrenPost (t,post) + | _ -> Cil.DoChildren + + method vpredicate_named p = match p.content with + | Pat (p, l) -> + let old_label = self#change_label l in + let new_p = {p with content = Pnot p} in + Cil.ChangeDoChildrenPost (new_p, self#restore_pred old_label) + | Papp _ -> + let post = function + | {content=Papp(predicate,labels,args)} as p -> + let new_labels = + List.map + (fun (logic,stmt) -> logic, label_map stmt) + labels + in { p with content=Papp(predicate,new_labels,args) } + | _ -> assert false + in + Cil.ChangeDoChildrenPost (p,post) + | _ -> Cil.DoChildren +end + +exception LabelError of logic_label + +let labels_empty l = raise (LabelError l) + +( -------------------------------------------------------------------------- ) +( --- Function Contracts --- ) +( -------------------------------------------------------------------------- ) + +let labels_fct_pre = function + | LogicLabel (None, ("Pre" | "Here")) -> Logic_const.pre_label + | l -> raise (LabelError l) + + +let labels_fct_post = function + | LogicLabel (None, ("Pre" | "Old")) -> Logic_const.pre_label + | LogicLabel (None, ("Post" | "Here")) -> Logic_const.post_label + | l -> raise (LabelError l) + +let labels_fct_assigns = function + | LogicLabel (None, "Post") -> Logic_const.post_label + | LogicLabel (None, ("Pre" | "Old")) -> Logic_const.pre_label + | l -> raise (LabelError l) + +( -------------------------------------------------------------------------- ) +( --- Statements Contracts --- ) +( -------------------------------------------------------------------------- ) +let labels_stmt_pre s = function + | LogicLabel (None, "Pre") -> Logic_const.pre_label ( fct pre-state ) + | LogicLabel (None, "Here") -> Clabels.mk_logic_label s + | LogicLabel (Some s, _) -> Clabels.mk_logic_label s + | StmtLabel rs -> Clabels.mk_logic_label !rs + | l -> raise (LabelError l) + +let labels_stmt_post s l_post = function + | LogicLabel (None, "Pre") -> Logic_const.pre_label ( fct pre-state ) + | LogicLabel (None, "Old") -> Clabels.mk_logic_label s ( contract pre-state ) + | LogicLabel (None, ("Here" | "Post")) as l -> + begin match l_post with Some l -> l + | None -> ( TODO ? ) raise (LabelError l) + end + | LogicLabel (Some s, _) -> Clabels.mk_logic_label s + | StmtLabel rs -> Clabels.mk_logic_label !rs + | l -> raise (LabelError l) + +let labels_stmt_assigns s l_post = function + | LogicLabel (None, "Pre") -> Logic_const.pre_label ( fct pre-state ) + | LogicLabel (None, ("Here" | "Old")) -> ( contract pre-state ) + Clabels.mk_logic_label s + | LogicLabel (None, "Post") -> labels_stmt_post s l_post Logic_const.post_label + | LogicLabel (Some s, _) -> Clabels.mk_logic_label s + | StmtLabel rs -> Clabels.mk_logic_label !rs + | l -> raise (LabelError l) + +( -------------------------------------------------------------------------- ) +( --- User Assertions in Functions Code --- ) +( -------------------------------------------------------------------------- ) + +let labels_assert_before s = function + | LogicLabel (None, "Pre") -> Logic_const.pre_label + | LogicLabel (None, "Here") -> Clabels.mk_logic_label s + | LogicLabel (Some s, _) -> Clabels.mk_logic_label s + | StmtLabel rs -> Clabels.mk_logic_label !rs + | l -> raise (LabelError l) + +let labels_assert_after s l_post = function + | LogicLabel (None, "Pre") -> Logic_const.pre_label + | LogicLabel (None, "Here") -> + labels_stmt_post s l_post Logic_const.post_label + | LogicLabel (Some s, _) -> Clabels.mk_logic_label s + | StmtLabel rs -> Clabels.mk_logic_label !rs + | l -> raise (LabelError l) + +let labels_loop_inv _s = function + | LogicLabel (None, "Pre") -> Logic_const.pre_label + | LogicLabel (None, "Here") -> Logic_const.here_label + | LogicLabel (None, ("Old" | "Post")) as l -> raise (LabelError l) + | l -> l + +let labels_loop_assigns s l = labels_loop_inv s l + +( -------------------------------------------------------------------------- ) +( --- User Defined Predicates --- ) +( -------------------------------------------------------------------------- ) + +let labels_predicate lab_pairs = fun l -> + try List.assoc l lab_pairs + with Not_found -> l + +let labels_axiom = function + | LogicLabel (None, ("Pre"|"Old"|"Post")) as l -> raise (LabelError l) + | LogicLabel (None, _) as l -> l + | l -> raise (LabelError l) + +( -------------------------------------------------------------------------- ) +( --- Apply Normalization --- ) +( -------------------------------------------------------------------------- *) + +(** @raise LabelError if there is a label in [p] that is incompatible +* with the [labels] translation *) +let preproc_annot labels p = + let visitor = new norm_at labels in + Visitor.visitFramacPredicateNamed visitor p + +(** @raise LabelError if there is a label in [p] that is incompatible +* with the [labels] translation *) +let preproc_assigns labels asgns = + let visitor = new norm_at labels in + List.map (Visitor.visitFramacFrom visitor) asgns + +let preproc_label labels l = labels l + +let catch_label_error ex txt1 txt2 = match ex with + | LabelError lab -> + Wp_parameters.warning + "Unexpected label %a in %s : ignored %s" + Wp_error.pp_logic_label lab txt1 txt2 + | _ -> raise ex diff -Nru frama-c-20110201+carbon+dfsg/src/wp/normAtLabels.mli frama-c-20111001+nitrogen+dfsg/src/wp/normAtLabels.mli --- frama-c-20110201+carbon+dfsg/src/wp/normAtLabels.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/normAtLabels.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,49 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types + +(* exception LabelError of logic_label ) +val catch_label_error : exn -> string -> string -> unit + +type label_mapping + +val labels_empty : label_mapping +val labels_fct_pre : label_mapping +val labels_fct_post : label_mapping +val labels_fct_assigns : label_mapping +val labels_assert_before : stmt -> label_mapping +val labels_assert_after : stmt -> logic_label option -> label_mapping +val labels_loop_inv : stmt -> label_mapping +val labels_loop_assigns : stmt -> label_mapping +val labels_stmt_pre : stmt -> label_mapping +val labels_stmt_post : stmt -> logic_label option -> label_mapping +val labels_stmt_assigns : stmt -> logic_label option -> label_mapping +val labels_predicate : (logic_label logic_label) list -> label_mapping +val labels_axiom : label_mapping + +val preproc_annot : label_mapping -> predicate named -> predicate named + +val preproc_assigns : + label_mapping -> identified_term from list -> identified_term from list + +val preproc_label : label_mapping -> logic_label -> logic_label diff -Nru frama-c-20110201+carbon+dfsg/src/wp/po_navigator.ml frama-c-20111001+nitrogen+dfsg/src/wp/po_navigator.ml --- frama-c-20110201+carbon+dfsg/src/wp/po_navigator.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/po_navigator.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,280 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* This is the panel to control the status of proof obligations. ) + +open Design +open Cil_types +open Wpo + +type row = { + wpo: Wpo.t; + visible : bool +} + +( Contains the prover associated to the given column ) +module Prover_Column = struct + let column_tbl = Hashtbl.create 7 + let get (col:GTree.view_column) = + try Some (Hashtbl.find column_tbl col#misc#get_oid) + with Not_found -> None + let register col prover = Hashtbl.add column_tbl col#misc#get_oid prover +end + +module SelectionHook=Hook.Build(struct type t = Wpo.t end) + +let refresh_current_wpo = ref (None : (Wpo.t (prover * result) list) option) +let refresh_panel_callback = ref (fun () -> ()) +let refresh_status_callback = ref (fun () -> ()) + +let make_panel (main_ui:main_window_extension_points) = + let container = GPack.vbox () in + let paned = GPack.paned `VERTICAL + ~packing:(container#pack ~expand:true ~fill:true) + () + in + (* Save position of the vpaned ) + let _ = paned#event#connect#button_release + ~callback:(fun _ -> + Gtk_helper.save_paned_ratio "po_navigator_paned" paned; false) + in + let module MODEL = Gtk_helper.MAKE_CUSTOM_LIST(struct type t = row end) in + let model = MODEL.custom_list () in + + let model_age = ref 0 in + let append m = + incr model_age; + if m.visible then model#insert m + in + let clear () = incr model_age; model#clear () in + let sc = + GBin.scrolled_window + ~vpolicy:`AUTOMATIC + ~hpolicy:`AUTOMATIC + ~packing:paned#add1 + () + in + let view = + GTree.view ~rules_hint:true ~headers_visible:true ~packing:sc#add () + in + ignore + (view#connect#row_activated + ~callback:(fun path col -> + match model#custom_get_iter path,Prover_Column.get col with + | Some ({MODEL.finfo= {wpo=wpo}} as custom), Some prover when prover <> WP + -> + ( copy to prevent Gtk to free it too soon. + Bug in all pre 2.14 versions of Lablgtk2 ) + let path = GtkTree.TreePath.copy path in + + Gui_parameters.debug "Activate %s prover:%a" + wpo.Wpo.po_name Wpo.pp_prover prover ; + let current_model_age = !model_age in + let callout _wpo _prover _result = + if current_model_age = !model_age then + begin + model#custom_row_changed path custom; + Gui_parameters.debug "Custom row changed"; + end; + main_ui#rehighlight () + in + Wpo.set_result wpo prover Wpo.Computing ; + model#custom_row_changed path custom ; + let server = Prover.server () in + let task = + Prover.prove ~callout wpo ~interactive:true prover + in + Task.spawn server task ; + Task.launch server + | _ -> ())); + view#selection#set_select_function + (fun path currently_selected -> + if not currently_selected then + begin match model#custom_get_iter path with + | Some {MODEL.finfo = {wpo=wpo};} -> + Gui_parameters.debug "Select %s@." wpo.Wpo.po_name; + SelectionHook.apply wpo + | None -> () + end; + true); + + let top = `YALIGN 0.0 in + + ( Generic function to add a textual column to the panel. ) + let add_text_column ~title f = + let cview = MODEL.make_view_column model + (GTree.cell_renderer_text [top]) + (fun {wpo=wpo} -> [`TEXT (f wpo)]) + ~title + in + cview#set_resizable true; + ignore (view#append_column cview) + in + + add_text_column + ~title:"Module" + (fun wpo -> + ((fst(Kernel_function.get_location wpo.Wpo.po_fun)).Lexing.pos_fname)) ; + + add_text_column + ~title:"Function" + (fun wpo -> (Kernel_function.get_name wpo.Wpo.po_fun)); + + add_text_column + ~title:"Behavior" + (fun wpo -> match wpo.Wpo.po_bhv with + | None -> "" + | Some b -> b); + + add_text_column + ~title:"Model" + (fun wpo -> wpo.Wpo.po_model); + + add_text_column + ~title:"Property" + (fun wpo -> WpPropId.name_of_prop_id wpo.Wpo.po_pid) ; + + add_text_column + ~title:"Kind" + (fun wpo -> WpPropId.label_of_prop_id wpo.Wpo.po_pid); + + let icon_of_result = function + | Wpo.Valid -> "gtk-yes" + | Wpo.Failed _ -> "gtk-dialog-error" + | Wpo.Unknown -> "gtk-dialog-question" + | Wpo.Timeout -> "gtk-cut" + | Wpo.Invalid -> "gtk-no" + | Wpo.Computing -> "gtk-execute" + in + + let name_of_prover = function + | Why s -> String.capitalize s + | AltErgo -> "Alt-Ergo" + | Coq -> "Coq" + | WP -> "WP" + in + + ( Prover columns ) + let make_prover_status prover = + let cview = MODEL.make_view_column model + (GTree.cell_renderer_pixbuf [top]) + (fun {wpo=wpo} -> + match Wpo.get_result wpo prover with + | Some r -> [ `STOCK_ID (icon_of_result r) ] + | None -> + if prover=WP + then [ `PIXBUF(Gtk_helper.Icon.get Gtk_helper.Icon.Unmark) ] + else [ `STOCK_ID "" ]) + ~title:(name_of_prover prover) + in + cview#set_resizable true; + cview#set_clickable true; + ignore (cview#connect#clicked + (fun () -> + Gui_parameters.debug "Clicked on column %a" Wpo.pp_prover prover)) ; + ignore (view#append_column cview); + Prover_Column.register cview prover + in + List.iter make_prover_status Wpo.gui_provers ; + + ( Last column is empty and juste uses the extra white space ) + let last_column = GTree.view_column ~title:"" () in + ignore (view#append_column last_column); + + view#set_model (Some model#coerce); + + let information_window = Source_manager.make ~packing:paned#add2 ~tab_pos:`RIGHT () in + SelectionHook.extend + (fun wpo -> + let results = Wpo.get_results wpo in + match !refresh_current_wpo with + | Some (wold,rold) when + (wold.po_gid = wpo.po_gid) && (Pervasives.compare rold results = 0) -> () + | _ -> + begin + refresh_current_wpo := Some (wpo,results) ; + Source_manager.clear information_window ; + List.iter + (fun (title,filename) -> + Source_manager.load_file information_window ~title ~filename ~line:1 ()) + [ + "Obligation" , Wpo.file_for_body ~gid:wpo.po_gid ; + "Description" , Wpo.file_for_head ~gid:wpo.po_gid ; + "Environment" , Wpo.file_for_ctxt ~env:wpo.po_env ; + ] ; + List.iter + (fun (prover,result) -> + if prover <> Wpo.WP && result <> Wpo.Computing then + let title = name_of_prover prover in + let filename = Wpo.file_for_log_proof ~gid:wpo.Wpo.po_gid prover in + Source_manager.load_file information_window ~title ~filename () + ) results ; + Source_manager.select_name information_window "Obligation" ; + end + ) ; + + let fill_model () = + Wpo.iter ~on_goal:(fun wpo -> append {wpo=wpo; visible=true}) () + in + + refresh_panel_callback := + (fun () -> + main_ui#protect ~cancelable:false + (fun () -> + clear (); + if paned#position < 64 then paned#set_position 64 ; + fill_model ())) ; + + refresh_status_callback := + (fun () -> + model#foreach (fun p i -> model#row_changed p i;false) ; + match !refresh_current_wpo with + | None -> () + | Some (wpo,_) -> SelectionHook.apply wpo + ) ; + + (To position the panels at startup:) + let (_:GtkSignal.id) = view#misc#connect#after#realize + (fun () -> + !refresh_panel_callback () ; + Gtk_helper.place_paned paned + (Gtk_helper.Configuration.find_float + ~default:0.60 + "po_navigator_paned")) + in + ignore (main_ui#lower_notebook#append_page + ~tab_label:(GMisc.label ~text:"WP Proof Obligations" ())#coerce + (container#coerce)) + +let extend (main_ui:main_window_extension_points) = + make_panel main_ui + +let () = Design.register_extension extend + +let refresh_panel () = !refresh_panel_callback () +let refresh_status () = !refresh_status_callback () + +( + Local Variables: + compile-command: "make -C ../.." + End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/po_navigator.mli frama-c-20111001+nitrogen+dfsg/src/wp/po_navigator.mli --- frama-c-20110201+carbon+dfsg/src/wp/po_navigator.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/po_navigator.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,36 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Extension of the GUI in order to navigate in Proof obligations. + No function is exported. *) + +val refresh_panel : unit -> unit + (** To be called when the set of POs has changed *) + +val refresh_status : unit -> unit + (** To be called when the status of POs has changed ) + +( + Local Variables: + compile-command: "make -C ../.." + End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/proof.ml frama-c-20111001+nitrogen+dfsg/src/wp/proof.ml --- frama-c-20110201+carbon+dfsg/src/wp/proof.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/proof.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,200 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Proof Script Database --- ) +( -------------------------------------------------------------------------- ) + +let scriptbase = Hashtbl.create 81 +let scriptfile = ref None ( current file script name ) +let needback = ref true ( file script need backup before modification ) +let needsave = ref true ( file script need to be saved ) + +let clear () = + begin + Hashtbl.clear scriptbase ; + scriptfile := None ; + needback := false ; + needsave := false ; + end + +let register_script goal keys proof = + Hashtbl.replace scriptbase goal (List.sort String.compare keys,proof) + +( -------------------------------------------------------------------------- ) +( --- Proof Scripts Parsers --- ) +( -------------------------------------------------------------------------- ) + +open Script + +let parse_coqproof file = + let input = Script.open_file file in + try + let rec fetch_proof input = + match token input with + | Proof p -> Some p + | Eof -> None + | _ -> skip input ; fetch_proof input + in + let proof = fetch_proof input in + Script.close input ; proof + with e -> + Script.close input ; + raise e + +let rec collect_scripts input = + while key input "Goal" do + let g = ident input in + eat input "." ; + let xs = + if key input "Hint" then + let xs = idents input in + eat input "." ; xs + else [] in + let p = + match token input with + | Proof p -> skip input ; p + | _ -> error input "Missing proof" + in + register_script g xs p + done ; + if token input <> Eof + then error input "Unexpected script declaration" + +let parse_scripts file = + if Sys.file_exists file then + begin + let input = Script.open_file file in + try + collect_scripts input ; + Script.close input ; + with e -> + Script.close input ; + raise e + end + +let dump_scripts file = + let out = open_out file in + let fmt = Format.formatter_of_out_channel out in + try + Format.fprintf fmt "( Generated by Frama-C (WP) )@\n@\n" ; + Hashtbl.iter + (fun goal (keys,proof) -> + Format.fprintf fmt "Goal %s.@\n" goal ; + (match keys with + | [] -> () + | k::ks -> + Format.fprintf fmt "Hint %s" k ; + List.iter (fun k -> Format.fprintf fmt ",%s" k) ks ; + Format.fprintf fmt ".@\n"); + Format.fprintf fmt "Proof.@\n%sQed.@\n@." proof) + scriptbase ; + Format.pp_print_newline fmt () ; + close_out out ; + with e -> + Format.pp_print_newline fmt () ; + close_out out ; + raise e + +( -------------------------------------------------------------------------- ) +( --- Scripts Management --- ) +( -------------------------------------------------------------------------- ) + +let rec choose k = + let file = Printf.sprintf "wp%d.script" k in + if Sys.file_exists file then choose (succ k) else file + +let savescripts () = + if !needsave then + match !scriptfile with + | None -> () + | Some file -> + try + if !needback then + ( Command.copy file (file ^ ".back") ; needback := false ) ; + dump_scripts file ; + needsave := false ; + with e -> + Wp_parameters.abort + "Error when dumping script file '%s':@\n%s" file + (Printexc.to_string e) + +let loadscripts () = + let user = Wp_parameters.Script.get () in + if !scriptfile <> Some user then + begin + savescripts () ; + let file = + if user = "" then + let ftmp = choose 0 in + Wp_parameters.warning + "No script file specified.@\n\ + Your proofs would be saved in '%s'@\n\ + Use -wp-script '%s' to re-run them." + ftmp ftmp ; + Wp_parameters.Script.set ftmp ; + ftmp + else + user + in + scriptfile := Some file ; + ( keep needsave *) + if Sys.file_exists file then + begin + needback := true ; + try parse_scripts user ; + with e -> + Wp_parameters.abort + "Error in script file '%s':@\n%s" user + (Printexc.to_string e) + end + else + needback := false + end + +let find_script_for_goal goal = + loadscripts () ; + try Some(snd (Hashtbl.find scriptbase goal)) + with Not_found -> None + +let rec suitable h mask keys = + match mask , keys with + | m::ms , k::ks -> + let c = String.compare m k in + if c < 0 then suitable h ms keys else + if c > 0 then suitable h mask ks else + suitable (succ h) ms ks + | _ -> h + +let most_suitable (h,_) (h',_) = h'-h + +let find_script_for_keywords keys = + loadscripts () ; + Hashtbl.fold + (fun _ (xs,p) scripts -> + let h = suitable 0 xs keys in + if h>0 then List.merge most_suitable [h,p] scripts + else scripts) + scriptbase [] + +let add_script goal keys proof = + needsave := true ; register_script goal keys proof diff -Nru frama-c-20110201+carbon+dfsg/src/wp/proof.mli frama-c-20111001+nitrogen+dfsg/src/wp/proof.mli --- frama-c-20110201+carbon+dfsg/src/wp/proof.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/proof.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,60 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Proof Script Database ) +( -------------------------------------------------------------------------- *) + +(** {2 Database} *) + +val add_script : string -> string list -> string -> unit + (** [new_script goal keys proof] registers the script [proof] for goal [goal] + and keywords [keys] *) + +val find_script_for_goal : string -> string option + (** Retrieve script file for one specific goal. The file specified + by [-wp-script f] is loaded if necessary. ) + +val find_script_for_keywords : string list -> (int string) list + (** Retrieve matchable script files for w.r.t provided keywords. + Most suitable scripts comes first. *) + +val clear : unit -> unit + +val loadscripts : unit -> unit + (** Load scripts from [-wp-script f]. Automatically invoked by [find_xxx] unless + [loadscripts] flags is unset. *) + +val savescripts : unit -> unit + (** If necessary, dump the scripts database into the file + specified by [-wp-script f]. *) + +(** {2 Low-level Parsers and Printers} *) + +val parse_coqproof : string -> string option + (** [parse_coqproof f] parses a coq-file [f] and fetch the first proof. *) + +val parse_scripts : string -> unit + (** [parse_scripts f] parses all scripts from file [f] and put them in the database. *) + +val dump_scripts : string -> unit + (** [dump_scripts f] saves all scripts from the database into file [f]. *) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/prover.ml frama-c-20111001+nitrogen+dfsg/src/wp/prover.ml --- frama-c-20110201+carbon+dfsg/src/wp/prover.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/prover.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,604 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Prover Implementation against Task API --- ) +( -------------------------------------------------------------------------- ) + +open Task +open Wpo +type verdict = Valid | Invalid | Unknown + +( -------------------------------------------------------------------------- ) +( --- File Preparation Utilities --- ) +( -------------------------------------------------------------------------- ) + +let cat files cout = + let buffer = String.create 2048 in + List.iter + (fun f -> + let cin = open_in f in + try + Command.bincopy buffer cin cout ; + close_in cin + with e -> + close_in cin ; raise e) + files + +let export file preludes pp = + let cout = open_out file in + try + cat preludes cout ; + flush cout ; + let fmt = Format.formatter_of_out_channel cout in + pp fmt ; + Format.pp_print_newline fmt () ; + Format.pp_print_flush fmt () ; + close_out cout ; + with err -> + close_out cout ; + raise err + +( managment of the file PO_log.txt generated into the output_dir ) +module Logs = +struct + + type t = { + logid : string ; + logout : out_channel ; + logfmt : Format.formatter ; + mutable logcmd : (string string array) option ; + mutable files : string list ; + } + + let create w logfile = + let outc = open_out logfile in + let fmt = Format.formatter_of_out_channel outc in + { + logid = w.po_gid ; + logout = outc ; + logfmt = fmt ; + logcmd = None ; + files = [] ; + } + + let pp_command fmt cmd args = + begin + Format.fprintf fmt "@[<hov 4>%s" cmd ; + Array.iter + (fun arg -> Format.fprintf fmt "@ %s" arg) + args ; + Format.fprintf fmt "@]@." ; + end + + let pp_current fmt t = + match t.logcmd with + | None -> () + | Some (cmd,args) -> pp_command fmt cmd args + + let pp_status fmt = + function + | Task.Result res -> + if res <> 0 then Format.fprintf fmt "Exit [%d]@." res + | Task.Canceled -> + Format.fprintf fmt "Timeout@." + | Task.Failed exn -> + Format.fprintf fmt "Failed \"%s\"@." (Printexc.to_string exn) + + let command t cmd args = + begin + t.logcmd <- Some (cmd,args) ; + pp_command t.logfmt cmd args ; + end + + let add_file t f = t.files <- f :: t.files + + let log_status t st = Format.fprintf t.logfmt "Run %a" pp_status st + + let is_error ?(status=[0]) = function + | Task.Result r -> not (List.mem r status) + | Task.Canceled -> false + | Task.Failed _ -> true + + let output t ?status (stdout:Buffer.t) st = + let msg = Buffer.contents stdout in + begin + log_status t st ; + Format.pp_print_string t.logfmt msg ; + Format.pp_print_newline t.logfmt () ; + if is_error ?status st then + begin + let cname = match t.logcmd with None -> "<?>" | Some (cmd,_) -> cmd in + Wp_parameters.error "command '%s' failed." cname ; + if not !Config.is_gui then + Log.print_on_output (fun fmt -> Format.fprintf fmt "%a%s" pp_current t msg) ; + end + end + + let clean files = + if not (Wp_parameters.is_out ()) then + List.iter + (fun file -> + try if Sys.file_exists file then Unix.unlink file ; + with Unix.Unix_error(err,_,_) -> + Wp_parameters.debug ~dkey:"tmp" "removing tmp file '%s':@ %s" + file (Unix.error_message err) + ) files + + let close_out t = + try + Format.pp_print_flush t.logfmt () ; + Pervasives.close_out t.logout ; + with exn -> + Wp_parameters.failure "Can not close log file (%s)" + (Printexc.to_string exn) + + let close t = + begin + close_out t ; + clean t.files ; + t.files <- [] ; + t.logcmd <- None ; + end + +end + +(* -------------------------------------------------------------------------- ) +( --- Why & Other SMT --- ) +( -------------------------------------------------------------------------- ) + +module PO = +struct + + let make language w = + let gfile = Wpo.file_for_po ~gid:w.po_gid language in + export gfile [ + file_for_model ~model:w.po_model language ; + file_for_env ~env:w.po_env language ; + file_for_goal ~gid:w.po_gid language ; + ] (fun _fmt -> ()) ; + gfile + +end + +module SMT = +struct + + type t = { + ext : string ; ( file extension ) + why : string array ; ( why options ) + wdp : string array ; ( why-dp options ) + } + + let yices = { + ext = "smt" ; + why = [| "--smtlib" |] ; + wdp = [| "-smt-solver" ; "yices" |] ; + } + + let cvc3 = { + ext = "smt" ; + why = [| "--smtlib" |] ; + wdp = [| "-smt-solver" ; "cvc3" |] ; + } + + let z3 = { + ext = "z3.smt" ; + why = [| "--z3" |] ; + wdp = [| "-smt-solver" ; "z3" |] ; + } + + let simplify = { + ext = "sx" ; + why = [| "--simplify" |] ; + wdp = [| |] ; + } + + let vampire = { + ext = "vp"; + why = [| "--vampire" |]; + wdp = [| |]; + } + + let altergo = { + ext = "why" ; + why = [| "--alt-ergo" |] ; + wdp = [| |] ; + } + + let zenon = { + ext = "znn" ; + why = [| "--zenon" |] ; + wdp = [| |] ; + } + + let of_name dp = + match String.lowercase dp with + | "yices" -> yices + | "cvc3" -> cvc3 + | "z3" -> z3 + | "vampire" -> vampire + | "simplify" -> simplify + | "alt-ergo" -> altergo + | "zenon" -> zenon + | _ -> Wp_parameters.abort "Unknown prover '%s'" dp + + let translate logs smt w = + let goal = PO.make L_why w in + Logs.add_file logs goal ; + let base = Filename.chop_suffix goal ".why" in + let file = Printf.sprintf "%s_why.%s" base smt.ext in + Logs.add_file logs file ; + let args = Array.append smt.why [| goal |] in + let stdout = Buffer.create 512 in + Logs.command logs "why" args ; + Task.command ~stdout "why" args + >>? Logs.output logs stdout + >>= fun res -> + if res = 0 then Task.return file + else Task.failed "Why exit %d" res + + let whydp logs smt file = + let timeout = Wp_parameters.Timeout.get () in + let stdout = Buffer.create 80 in + let stderr = Buffer.create 80 in + let my_args = + if Wp_parameters.ProofTrace.get () then + [| "-batch"; "-debug"; file |] + else + [| "-batch"; file |] + in + let args = Array.append smt.wdp my_args in + Logs.command logs "why-dp" args ; + Task.command ~timeout ~stdout ~stderr "why-dp" args + >>? Logs.output logs ~status:[0;1;2;3;4] stdout + >>? Logs.output logs stderr + ( why-dp returns the output of the prover on stderr ) + >>= fun res -> + if res = 0 then Task.return Valid + else + if (1<= res && res <= 4) then Task.return Unknown + else Task.failed "Why-dp exit %d" res + + let prove dp log w = + let smt = of_name dp in + translate log smt w >>= whydp log smt + + let check logs w = + let timeout = Wp_parameters.Timeout.get () in + let stdout = Buffer.create 80 in + let goal = PO.make L_why w in + Logs.add_file logs goal ; + let args = [| "--type-only" ; goal|] in + Logs.command logs "why" args; + Task.command ~timeout ~stdout "why" args + >>? Logs.output logs stdout + >>= fun res -> + if res = 0 then Task.return Valid else Task.return Invalid + +end + +( -------------------------------------------------------------------------- ) +( --- Prover Alt-Ergo --- ) +( -------------------------------------------------------------------------- ) + +module AltErgo = +struct + + let valid = Str.regexp "\\bValid\\b" + + let prove logs w = + let timeout = Wp_parameters.Timeout.get () in + let stdout = Buffer.create 80 in + let goal = PO.make L_altergo w in + Logs.add_file logs goal ; + let args = + if Wp_parameters.ProofTrace.get () + then [| "-proof" ; goal |] + else [| goal |] + in + Logs.command logs "alt-ergo" args ; + Task.command ~timeout ~stdout "alt-ergo" args + >>? Logs.output logs stdout + >>= fun s -> + if s=0 then + let response = Buffer.contents stdout in + try + ignore (Str.search_forward valid response 0) ; + Task.return Valid + with Not_found -> + Task.return Unknown + else + Task.failed "Alt-Ergo exit %d" s + + let check logs w = + let timeout = Wp_parameters.Timeout.get () in + let stdout = Buffer.create 80 in + let goal = PO.make L_altergo w in + Logs.add_file logs goal ; + let args = [| "-type-only"; goal |] in + Logs.command logs "alt-ergo" args ; + Task.command ~timeout ~stdout "alt-ergo" args + >>? Logs.output logs stdout + >>= fun s -> + if (s = 0) then Task.return Valid + else Task.return Invalid + +end + + +( -------------------------------------------------------------------------- ) +( --- Prover Coq --- ) +( -------------------------------------------------------------------------- ) + + +module Coq = +struct + + let compiled : (string,unit Task.task) Hashtbl.t = Hashtbl.create 83 + let revert_on_error key = function + | Task.Result _ -> () + | _ -> Hashtbl.remove compiled key + let once key cc = + try Hashtbl.find compiled key + with Not_found -> + let t = Task.nop >>= cc >>? revert_on_error key in + Hashtbl.add compiled key t ; t + + let result_compile file r = + if r<>0 + then Task.failed "Compilation of '%s' failed" file + else Task.return () + + let require_wp logs = + once "wp" + (fun () -> + let denv = Wp_parameters.get_output () in + let dshare = Wp_parameters.get_share() in + let shared = Format.sprintf "%s/wp.v" dshare in + let work = Format.sprintf "%s/wp.v" denv in + Command.copy shared work ; + ( no added ! -> incremental compilation ) + let args = [| "-noglob" ; work |] in + let stdout = Buffer.create 512 in + let timeout = Wp_parameters.Timeout.get() in + Logs.command logs "coqc" args ; + Task.command ~timeout ~stdout "coqc" args + >>? Logs.output logs stdout + >>= result_compile work) + + let require_model logs w = + let model = w.po_model in + once model + (fun () -> + let file = Wpo.file_for_model ~model L_coq in + let fcoq = Wpo.coqc_for_model ~model in + Command.copy file fcoq ; + ( not added ! -> incremental compilation ) + let denv = Wp_parameters.get_output () in + let args = [| "-noglob" ; "-I" ; denv ; fcoq |] in + let stdout = Buffer.create 512 in + let timeout = Wp_parameters.Timeout.get() in + Logs.command logs "coqc" args ; + Task.command ~timeout ~stdout "coqc" args + >>? Logs.output logs stdout + >>= result_compile fcoq) + + let require_env logs w = + let env = w.po_env in + once env + (fun () -> + let denv = Wp_parameters.get_output () in + let file = file_for_env env L_coq in + ( not added ! -> incremental compilation ) + let args = [| "-noglob"; "-I" ; denv ; file |] in + let stdout = Buffer.create 512 in + let timeout = Wp_parameters.Timeout.get() in + Logs.command logs "coqc" args ; + Task.command ~timeout ~stdout "coqc" args + >>? Logs.output logs stdout + >>= result_compile file) + + let default = + " ( FILL PROOF HERE.)\n \ + intros; repeat(split; intros); auto;\n \ + try contradiction; auto; eauto ; try omega.\n" + + let proof logs w script = + let gid = w.po_gid in + let env = w.po_env in + let model = w.po_model in + let goal = Wpo.file_for_goal ~gid L_coq in + let proof = Wpo.file_for_po ~gid L_coq in + Command.pp_to_file proof + (fun fmt -> + Format.fprintf fmt "Require Import Reals.@\n"; + Format.fprintf fmt "Require Import wp.@\n"; + Format.fprintf fmt "Require Import %s.@\n" (Wpo.coq_for_model ~model); + Format.fprintf fmt "Require Import %s.@\n" (Wpo.coq_for_env ~env); + Command.pp_from_file fmt goal ; + begin + match script with + | Some script -> + Format.fprintf fmt "Proof.@\n%sQed.@\n@." script ; + | None -> ( This case is for check) + Format.fprintf fmt "Proof.@\nAdmitted.@\n@." ; + end + ) ; + Logs.add_file logs proof ; + Task.return proof + + let coqc logs w script = + proof logs w script >>= + fun fgoal -> + let fgoal = Filename.chop_suffix fgoal ".v" in + Logs.add_file logs (fgoal ^ ".vo") ; + let denv = Wp_parameters.get_output() in + let timeout = Wp_parameters.Timeout.get() in + let stdout = Buffer.create 512 in + let args = [| "-noglob";"-I" ; denv ; "-compile"; fgoal |] in + Logs.command logs "coqtop" args ; + Task.command ~timeout ~stdout "coqtop" args + >>? Logs.output logs ~status:[0;1] stdout + + let script_for w = + Some + ( match Proof.find_script_for_goal w.po_gid with + | None -> default + | Some script -> script ) + + let prove log w = + require_wp log + >>= fun _ -> require_model log w + >>= fun _ -> require_env log w + >>= fun _ -> coqc log w (script_for w) + >>= Task.call (fun r -> if r=0 then Valid else Unknown) + + let check log w = + require_wp log + >>= fun _ -> require_model log w + >>= fun _ -> require_env log w + >>= fun _ -> coqc log w None + >>= Task.call (fun r -> if r=0 then Valid else Invalid) + + +end + +module Coqide = +struct + + let coqidelock = Task.mutex () + + let run_coqide logs w proof = + let denv = Wp_parameters.get_output() in + let gid = w.po_gid in + let coqide () = + let head = Wpo.file_for_head gid in + let env = Wpo.file_for_env w.po_env L_coq in + let model = Wpo.coqc_for_model ~model:w.po_model in + let dshare = Wp_parameters.get_share() in + let wp_share = Format.sprintf "%s/wp.v" dshare in + let args = + match Wp_parameters.Script.get() with + | fscript when Sys.file_exists fscript -> + [| "-I" ; denv ; proof; head; env; model; wp_share; fscript |] + | _ -> + [| "-I" ; denv ; proof; head; env; model; wp_share |] + in + Logs.command logs "coqide" args ; + Task.command "coqide" args + >>? Logs.log_status logs + in + Task.sync coqidelock coqide >>= + fun s -> + if s <> 0 then Task.return Unknown + else + match Proof.parse_coqproof proof with + | None -> + Wp_parameters.feedback "No proof found" ; + Task.return Unknown + | Some script -> + Wp_parameters.feedback "Check proof" ; + Coq.coqc logs w (Some script) >>= + Task.call + (fun s -> + Proof.add_script gid [] script ; + if s=0 then Valid else Unknown) + + let prove log w = + Coq.prove log w >>= function + | Unknown | Invalid -> + Coq.proof log w (Coq.script_for w) >>= + run_coqide log w + | Valid -> Task.return Valid + +end + +( -------------------------------------------------------------------------- ) +( --- Main Dispatcher --- ) +( -------------------------------------------------------------------------- *) + +let task_for interactive = function + | AltErgo -> AltErgo.prove + | Why dp -> SMT.prove dp + | Coq -> if interactive then Coqide.prove else Coq.prove + | WP -> fun _ _ -> Task.return Unknown + +let result = function + | Task.Result Valid -> Wpo.Valid + | Task.Result Invalid -> Wpo.Invalid + | Task.Result Unknown -> Wpo.Unknown + | Task.Canceled -> Wpo.Timeout + | Task.Failed exn -> Wpo.Failed (Printexc.to_string exn) + +let prove + ?(callin=fun _ _ -> ()) + ?(callout=fun _ _ _ -> ()) + wpo ~interactive prover + = + Task.todo + begin + fun () -> + let logf = Wpo.file_for_log_proof ~gid:wpo.po_gid prover in + let logs = Logs.create wpo logf in + (callin wpo prover ; + task_for interactive prover logs wpo) + >>! fun s -> + let r = result s in + Logs.close logs ; + Wpo.set_result wpo prover r ; + callout wpo prover r + end + +let check_by = function + | L_altergo -> AltErgo.check + | L_why -> SMT.check + | L_coq -> Coq.check + +let check + ?(callout=fun _ _ _ -> ()) + wpo lang + = + Task.todo + begin + fun () -> + let logf = Wpo.file_for_log_check ~gid:wpo.po_gid lang in + let log = Logs.create wpo logf in + check_by lang log wpo + >>! fun s -> + let r = result s in + Logs.close log ; + callout wpo lang r + end + +let server = ref None + +let server () = + match !server with + | Some s -> + let procs = Wp_parameters.Procs.get () in + Task.set_procs s procs ; s + | None -> + let procs = Wp_parameters.Procs.get () in + let s = Task.server ~procs () in + Task.on_server_stop s Proof.savescripts ; + server := Some s ; s diff -Nru frama-c-20110201+carbon+dfsg/src/wp/prover.mli frama-c-20111001+nitrogen+dfsg/src/wp/prover.mli --- frama-c-20110201+carbon+dfsg/src/wp/prover.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/prover.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,42 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Prover Implementation against Task API --- ) +( -------------------------------------------------------------------------- *) + +val server : unit -> Task.server + +(** {1 Prover Implementations} *) + +type verdict = Valid | Invalid | Unknown + +val prove : + ?callin:(Wpo.t -> Wpo.prover -> unit) -> + ?callout:(Wpo.t -> Wpo.prover -> Wpo.result -> unit) -> + Wpo.t -> interactive:bool -> Wpo.prover -> unit Task.task + +(** The task will run the prover and update the Wpo base accordingly. *) + +val check : + ?callout:(Wpo.t -> Wpo.language -> Wpo.result -> unit) -> + Wpo.t -> Wpo.language -> unit Task.task diff -Nru frama-c-20110201+carbon+dfsg/src/wp/register.ml frama-c-20111001+nitrogen+dfsg/src/wp/register.ml --- frama-c-20110201+carbon+dfsg/src/wp/register.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/register.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,572 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + + + +(* -------------------------------------------------------------------------- ) +( --- WP Models for VC generation --- ) +( -------------------------------------------------------------------------- ) + + +module F = Fol_formula +module A = Mint_natural.Create(F) +module R = Mfloat_natural.Create(F) + +module Hoare = Hoare_mem.Create(F)(A)(R) +module Store = Store_mem.Create(F)(A)(R) +module Runtime = Runtime_mem.Create(F)(A)(R) + +module Th = +struct + let tau_of_ctype_logic t = + Hoare.tau_of_object (Ctypes.object_of t) +end +module HW = Fol_why.EWhy(Th) +module HQ = Fol_coq.ECoq(Th) +module HE = Fol_ergo.Make(Th) + +module Ts = +struct + let tau_of_ctype_logic t = + Store.tau_of_object (Ctypes.object_of t) +end +module SW = Fol_why.EWhy(Ts) +module SQ = Fol_coq.ECoq(Ts) +module SE = Fol_ergo.Make(Ts) + +module Tr = +struct + let tau_of_ctype_logic t = + Runtime.tau_of_object (Ctypes.object_of t) +end +module RW = Fol_why.EWhy(Tr) +module RQ = Fol_coq.ECoq(Tr) +module RE = Fol_ergo.Make(Tr) + +module MCriteria : Funvar_mem.Criteria = struct let isHoare = false end + +module HCriteria : Funvar_mem.Criteria = struct let isHoare = true end + +( +module FQed = Fol_qed.F +module DQed = Datalib.Create(FQed) +module AQed = Mint_natural.Create(DQed) +module RQed = Mfloat_natural.Create(DQed) +module EQed = Fol_qed.E +) + +( --------- WP Calculus Engines ------------------ ) + +module WP_Hoare = + CfgProof.Create(Funvar_mem.Create(HCriteria)(Hoare))(HW)(HQ)(HE) + (Fol_split) + (struct + let shared = "hoare" + let context = "hoare" + let updater = "Hoare" + let name = "Hoare" + end) + +module WP_Store = CfgProof.Create(Store)(SW)(SQ)(SE) + (Fol_split) + (struct + let shared = "store" + let context = "store_full" + let updater = "Store-Full" + let name = "Store(full memory)" + end) + +module WP_Storefun = + CfgProof.Create(Funvar_mem.Create(MCriteria)(Store))(SW)(SQ)(SE) + (Fol_split) + (struct + let shared = "store" + let context = "store" + let updater = "Store" + let name = "Store" + end) + +module WP_Runtime = CfgProof.Create(Runtime)(RW)(RQ)(RE) + (Fol_split) + (struct + let shared = "runtime" + let context = "runtime_full" + let updater = "Runtime-Full" + let name = "Runtime(full memory)" + end) + +module WP_Runtimefun = + CfgProof.Create(Funvar_mem.Create(MCriteria)(Runtime))(RW)(RQ)(RE) + (Fol_split) + (struct + let shared = "runtime" + let context = "runtime" + let updater = "Runtime" + let name = "Runtime" + end) + +( --------- WP Dispatcher ------------------ ) + +type feature = NA | Yes | No + +type wp_model = { + wp_name : string ; + wp_qed : feature ; + wp_logicvar : feature ; + wp_method : unit -> Mcfg.assigns_method ; + wp_computer : unit -> CfgProof.computer ; + wp_altmodel : (unit -> CfgProof.computer) option ; +} + +let wp_model name = { + wp_name = name ; + wp_qed = NA ; + wp_logicvar = NA ; + wp_method = (fun () -> Wp_parameters.fatal "no method implemented") ; + wp_computer = (fun () -> Wp_parameters.fatal "computer not implemented") ; + wp_altmodel = None ; +} + +let option opt = function + | NA -> true + | Yes -> opt () + | No -> not (opt ()) + +type 'a computing_methods = + | OneforBoth of 'a + | NonAssigns of 'a + | OneforEach of 'a 'a (non assigns, assigns only) + +let dispatch models = + try + let model = List.find + (fun m -> + List.for_all + (fun (opt,f) -> + match f with + | NA -> true + | Yes -> opt () + | No -> not (opt ()) ) + [ + (fun () -> false) (Wp_parameters.Qed.get) , m.wp_qed ; + Wp_parameters.LogicVar.get , m.wp_logicvar ; + ] + ) models in + let computer = model.wp_computer () in + match model.wp_method () , model.wp_altmodel with + | Mcfg.NoAssigns , None -> NonAssigns computer + | Mcfg.NoAssigns , Some alt -> OneforEach( computer , alt () ) + | _ -> OneforBoth computer + with Not_found -> + Wp_parameters.abort "No model found with provided criteria" + +(* --------- WP Computer -------------------- ) + +( + computer returns : + - either one computer for both assigns and non-assigns + - or a unique computer for only non-assigns + - or two computers, one for assigns and one for non-assigns +) + +let computer = function + + | Wp_parameters.M_Hoare -> + NonAssigns (WP_Hoare.create ()) + | Wp_parameters.M_Store -> + dispatch [ + { (wp_model "Store") with + wp_logicvar = Yes ; + wp_method = WP_Storefun.assigns_method ; + wp_computer = WP_Storefun.create ; + wp_altmodel = Some WP_Store.create ; + } ; + { (wp_model "Store") with + wp_logicvar = No ; + wp_method = WP_Store.assigns_method ; + wp_computer = WP_Store.create ; + } + ] + + | Wp_parameters.M_Runtime -> + dispatch [ + { (wp_model "Runtime") with + wp_logicvar = Yes ; + wp_method = WP_Runtimefun.assigns_method ; + wp_computer = WP_Runtimefun.create ; + wp_altmodel = Some WP_Runtime.create ; + } ; + { (wp_model "Runtime") with + wp_logicvar = No ; + wp_method = WP_Runtime.assigns_method ; + wp_computer = WP_Runtime.create ; + } + ] + +( ------------------------------------------------------------------------ ) +( --- Iterators --- ) +( ------------------------------------------------------------------------ ) + +( TODO: clean that because we now do the same thing on functions with or +* without definition... +) + +let on_definition phi kf = + match kf.Cil_types.fundec with + | Cil_types.Declaration _ ( -> + Wp_parameters.warning ~current:false "Function %s has no body (skipped)" + (Kernel_function.get_name kf) ) + | Cil_types.Definition _ -> phi kf + +let on_all_functions = fun do_body -> + Globals.Functions.iter (fun kf -> + !Db.progress (); + (match kf.fundec with + | Declaration _ -> () + | Definition _ -> ) + on_definition do_body kf) + +let on_function_names fcts = fun do_body -> + List.iter + (fun fname -> + try + let kf = Globals.Functions.find_by_name fname in + on_definition do_body kf + with Not_found -> + Wp_parameters.error "Unknown function '%s' (skipped)" fname + ) fcts + +let on_function kf = fun do_body -> on_definition do_body kf + +( ------------------------------------------------------------------------ ) +( --- Shared Functions for both GUI and command line --- ) +( ------------------------------------------------------------------------ ) + + +let dot_lannots lannots = + let do_dot annots = + let cfg = WpStrategy.cfg_of_strategy annots in + let pp_annots fmt e = + WpStrategy.pp_annots fmt (WpStrategy.get_annots annots e) + in + let bhv = WpStrategy.behavior_name_of_strategy annots in + ignore (Cil2cfg.dot_annots cfg bhv pp_annots) + in List.iter do_dot lannots + +type prop = + | NamedProp of string + | IdProp of Property.t + +let do_compute + (goals : Wpo.t Bag.t ref) + (computer : CfgProof.computer) + fun_iter assigns behaviors property call_stmt_opt + = + let do_kf kf = + !Db.progress () ; + let annots = match behaviors, property with + | [], None -> + let s = match call_stmt_opt with + | Some stmt -> WpAnnot.get_call_pre_strategies stmt + | None -> + if Wp_parameters.Froms.get () + then WpFroms.get_strategies_for_froms kf + else WpAnnot.get_function_strategies ~assigns kf + in s + | (_ :: _) as bhvs, None -> + WpAnnot.get_behavior_strategies ~assigns kf bhvs + | _, Some (IdProp p) -> + WpAnnot.get_id_prop_strategies ~assigns p + | _, Some (NamedProp p) -> + WpAnnot.get_prop_strategies ~assigns kf (behaviors, p) + in + if Wp_parameters.Dot.get () then dot_lannots annots; + computer#add annots + in + begin + fun_iter do_kf ; + goals := Bag.concat !goals (Bag.list computer#compute) ; + end + +( ------------------------------------------------------------------------ ) +( --- Printing informations --- ) +( ------------------------------------------------------------------------ ) + +let do_wp_print () = + ( Printing ) + if Wp_parameters.Print.get () then + try + Wpo.iter ~on_goal:(fun _ -> raise Exit) () ; + Wp_parameters.result "No proof obligations" + with Exit -> + Log.print_on_output + (fun fmt -> + Wpo.iter + ~on_environment:(Wpo.pp_environment fmt) + ~on_behavior:(Wpo.pp_function fmt) + ~on_goal:(Wpo.pp_goal_flow fmt) ()) + +let do_wp_print_for goals = + if Wp_parameters.Print.get () then + if Bag.is_empty goals + then Wp_parameters.result "No proof obligations" + else Log.print_on_output + (fun fmt -> Bag.iter (Wpo.pp_goal_flow fmt) goals) + +( ------------------------------------------------------------------------ ) +( --- Proving --- ) +( ------------------------------------------------------------------------ ) + +let do_wpo_feedback g prover result = + Wp_parameters.feedback "[%a] Goal %s : %a" + Wpo.pp_prover prover g.Wpo.po_gid Wpo.pp_result result + +let do_wp_proof server interactive prover g = + let already_valid (_,r) = r=Wpo.Valid in + if not (List.exists already_valid (Wpo.get_results g)) + then begin + Task.spawn server + (Prover.prove ~callout:do_wpo_feedback g ~interactive prover) + end +let do_wp_proofs () = + let pname = Wp_parameters.Prover.get () in + match Wpo.prover_of_name pname with + | None -> () + | Some prover -> + let interactive = Wpo.is_interactive pname in + let server = Prover.server () in + try + Wpo.iter ~on_goal:(do_wp_proof server interactive prover) () ; + Task.launch server ; + with e -> + Task.cancel_all server ; + raise e + +let do_wp_proofs_for goals = + let pname = Wp_parameters.Prover.get () in + match Wpo.prover_of_name pname with + | None -> () + | Some prover -> + let interactive = Wpo.is_interactive pname in + let server = Prover.server () in + try + Bag.iter (do_wp_proof server interactive prover) goals ; + Task.launch server ; + with e -> + Task.cancel_all server ; + raise e + +( ------------------------------------------------------------------------ ) +( --- Type Checking prover's inputs --- ) +( ------------------------------------------------------------------------ ) + +let do_check_feedback g lang result = + Wp_parameters.feedback "[%a] Goal %s : %a" + Wpo.pp_language lang g.Wpo.po_gid Wpo.pp_result result + +let do_wp_check server lang g = + Task.spawn server (Prover.check ~callout:do_check_feedback g lang) + +let do_wp_checks () = + match Wpo.language_of_name (Wp_parameters.Check.get ()) with + | None -> () + | Some lang -> + let server = Prover.server () in + try + Wpo.iter ~on_goal:(do_wp_check server lang) () ; + Task.launch server ; + with e -> + Task.cancel_all server ; + raise e + +let do_wp_checks_for goals = + match Wpo.language_of_name (Wp_parameters.Check.get ()) with + | None -> () + | Some lang -> + let server = Prover.server () in + try + Bag.iter (do_wp_check server lang) goals ; + Task.launch server ; + with e -> + Task.cancel_all server ; + raise e + +( ------------------------------------------------------------------------ ) +( --- Filtering WP passes --- ) +( ------------------------------------------------------------------------ ) + +let do_wp_passes fun_iter behaviors property call_stmt_opt = + let model = Wp_parameters.get_model () in + let goals = ref Bag.empty in + let wp_pass computer assigns = + do_compute goals computer fun_iter assigns behaviors property call_stmt_opt + in + begin + match computer model with + | NonAssigns c -> + Wp_parameters.warning + ~current:false ~once:true + "Ignored Assigns-Goals with '%s' model" + (Wp_parameters.Model.get ()) ; + wp_pass c WpAnnot.NoAssigns + | OneforBoth c -> + wp_pass c WpAnnot.WithAssigns + | OneforEach(c1,c2) -> + match property with + | None + | Some + (NamedProp _ | IdProp(Property.IPOther _ + | Property.IPBehavior _ + | ( [JS 2011/08/05] I put this case here + but not sure of that ) + Property.IPUnreachable _)) + -> + begin + wp_pass c1 WpAnnot.NoAssigns ; + wp_pass c2 WpAnnot.OnlyAssigns ; + end + | Some(IdProp(Property.IPPredicate _ + | Property.IPAxiom _ | Property.IPLemma _ + | Property.IPAxiomatic _ + | Property.IPCodeAnnot _ | Property.IPComplete _ + | Property.IPDisjoint _ | Property.IPDecrease _ )) -> + wp_pass c1 WpAnnot.NoAssigns + | Some (IdProp(Property.IPAssigns _ | Property.IPFrom _)) -> + wp_pass c2 WpAnnot.OnlyAssigns + end; + !goals + +let generic_compute kf_opt behaviors p call_stmt = + let fun_iter = + match kf_opt with + | Some kf -> on_function kf + | None -> on_all_functions + in + let goals = do_wp_passes fun_iter behaviors p call_stmt in + if not (Bag.is_empty goals) then do_wp_proofs_for goals + +( ------------------------------------------------------------------------ ) +( --- Secondary Entry Points --- ) +( ------------------------------------------------------------------------ ) + +( Registered entry point in Dynamic. ) + +let wp_compute kf_opt behaviors property = + let p = match property with None -> None | Some p -> Some (IdProp p) in + generic_compute kf_opt behaviors p None + +let wp_compute_call ~kf_caller ~kf_called stmt = + ignore kf_called ; + generic_compute (Some kf_caller) [] None (Some stmt) + +( ------------------------------------------------------------------------ ) +( --- Command-line Entry Points --- ) +( ------------------------------------------------------------------------ ) + +let cmdline_run () = + let wp_main kf_list = + Ast.compute (); + Variables_analysis.precondition_compute (); + let fun_iter = match kf_list with + | [] -> on_all_functions + | names -> on_function_names names + in + let bhvs = Wp_parameters.Behaviors.get () in + let property = + match Wp_parameters.Properties.get () with + | [] -> None + | [ p ] -> Some (NamedProp p) + | ps -> + Wp_parameters.not_yet_implemented + "several properties (%a) in -wp-prop" + (Pretty_utils.pp_list ~sep:"," Format.pp_print_string) ps + in + do_wp_passes fun_iter bhvs property None + in + match Wp_parameters.job () with + | Wp_parameters.WP_None -> () + | Wp_parameters.WP_All -> + ignore (wp_main []); + do_wp_checks (); + do_wp_proofs (); + do_wp_print () + | Wp_parameters.WP_Select fcts -> + let goals = wp_main fcts in + do_wp_checks_for goals ; + do_wp_proofs_for goals ; + do_wp_print_for goals + +( ------------------------------------------------------------------------ ) +( --- Register external functions --- ) +( ------------------------------------------------------------------------ ) + +let property_of_id = + Dynamic.register ~plugin:"Wp" "WpAnnot.property_of_id" ~journalize:false + (Datatype.func WpPropId.Prop_id_datatype.ty Property.ty) + WpPropId.property_of_id + +let wp_compute = + let module OLS = Datatype.List(Datatype.String) in + let module OKF = Datatype.Option(Kernel_function) in + let module OP = Datatype.Option(Property) in + Dynamic.register ~plugin:"Wp" "wp_compute" + (Datatype.func3 OKF.ty OLS.ty OP.ty Datatype.unit) + ~journalize:false (LC: Because of Property is not journalizable. *) + wp_compute + +(** Use options to know what to do ) +let run = Dynamic.register ~plugin:"Wp" "run" + (Datatype.func Datatype.unit Datatype.unit) + ~journalize:true + cmdline_run + +( ------------------------------------------------------------------------ ) +( --- Main Entry Point --- ) +( ------------------------------------------------------------------------ ) + +let do_finally job1 job2 () = + let r1 = try job1 () ; None with error -> Some error in + let r2 = try job2 () ; None with error -> Some error in + match r1 , r2 with + | None , None -> () + | Some e1 , None -> raise e1 + | _ , Some e2 -> raise e2 + +let tracelog () = + let ks = Wp_parameters.get_debug_keyset () in + if ks <> [] then + let pp_keys : Format.formatter -> string list -> unit = + Pretty_utils.pp_flowlist ~left:"" ~sep:"," ~right:"." Format.pp_print_string + in Wp_parameters.debug ~level:0 "Logging keys : %a" pp_keys ks + +let (&&&) = do_finally + +let main = cmdline_run &&& tracelog &&& Wp_parameters.reset + +let () = Db.Main.extend main + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/runtime_mem.ml frama-c-20111001+nitrogen+dfsg/src/wp/runtime_mem.ml --- frama-c-20110201+carbon+dfsg/src/wp/runtime_mem.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/runtime_mem.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,935 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Memory Model for Runtime: +* more information about it in {{:../../wp/Notes/m3.html}this document} +* ) +( -------------------------------------------------------------------------- ) + +let dkey = "runtime" ( debugging key ) + +open Cil_types +open Cil_datatype + +let unsupported = Wp_error.unsupported + +type compute_int_mode = CIMterms | CIMvalues | CIMcompute + +module Create + (F:Formula.S) + (A:Mint.S with module F = F) + (R:Mfloat.S with module F = F) + = +struct + + type decl = F.decl + + (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*) + (** The memory is composed of 2 parts: one that deals with the values, + * and the other one that handle allocation information. More over, there + * is a table in the [Pre] memory to handle logic variables that are used for + * the initial value of the parameters. + * *) + + type m_mbits + let t_mbits : Formula.tau = Formula.ADT ("memory", []) + type mem_bits = m_mbits F.term + + type m_alloc + let t_alloc : Formula.tau = Formula.ADT ("memalloc", []) + type mem_alloc = m_alloc F.term + + type m_mem + let t_mem : Formula.tau = Formula.ADT ("memory", []) + type mem = { vbits : F.var ; valloc : F.var ;} + + + + type m_format + type format = m_format F.term + (** ----- Formats : ) + + let mk_iformat i = Pretty_utils.sfprintf "%a_format" Ctypes.pp_int i + let mk_fformat f = Pretty_utils.sfprintf "%a_format" Ctypes.pp_float f + let int_format = F.e_app0 "int_format" + let real_format = F.e_app0 "real_format" + let i_format i = F.e_app0 (mk_iformat i) + let f_format f = F.e_app0 (mk_fformat f) + let format_of_addr _ty = + ( format_of_c_int_type (Ctypes.c_ptr()) *) + F.e_app0 "rt_addr_format" + + + (**) + let tcomp_of_comp comp = (* TODO: we shouldn't loose the TComp ! ) + TComp (comp, {scache = Not_Computed}, []) + + let cil_field_info f = + let t = tcomp_of_comp (f.fcomp) in + try + let offset = Field (f, NoOffset) in + Cil.bitsOffset t offset + with Cil.SizeOfError (msg,t) -> + unsupported "sizeof %a : %s for field '%s'" + !Ast_printer.d_type t msg f.fname + let cil_field_offset f = fst (cil_field_info f) + let cil_field_size f = snd (cil_field_info f) + + let name_of_var vi : F.name = F.Xindex.get_ind vi + let name_of_field f = F.Findex.get_ind f + + + + + () + ( Size and offset are sometimes known constants. We can choose to + represent them are simple [int] and compute values as far as possible, + * or to keep them as named terms. + * The first solution gives smaller - yet easier provable - goals, + * but if if fails, the user has few information the understand the problem. + * We will try to have both solutions in order to be able to test them. + ) + + let compute_int_mode = CIMterms ( TODO: add an option ? *) + + (** integer terms with a phantom type to mark what kind of object it is. ) + type 'a tint = F.integer + + module Aint : sig + type 'a t + + val of_int : int -> 'a t + val of_int64 : Int64.t -> 'a t + val of_term : 'a tint -> 'a t + + val add : 'a t -> 'b t -> 'a t + val sub : 'a t -> 'b t -> 'a t + val cnst_mult : Int64.t -> 'a t -> 'a t + val mult : 'b t -> 'a t -> 'a t + + val to_term : 'a t -> 'a tint + + val eq_pred : 'a t -> 'a t -> F.pred + + end = struct + + let compute = (compute_int_mode = CIMcompute) + + type aint = + | AIcnst of Int64.t + | AIterm of F.integer + | AImult of Int64.t F.integer + | AIadd of aint * Int64.t + + type 'a t = aint + + let term_of_cnst i = F.e_icst (Int64.to_string i) + + let of_int64 i = if compute then AIcnst i else AIterm (term_of_cnst i) + let of_int (i:int) = of_int64 (Int64.of_int i) + let of_term t = AIterm t + + let term_of_add t1 t2 = F.e_iop Formula.Iadd t1 t2 + let term_of_sub t1 t2 = F.e_iop Formula.Isub t1 t2 + let term_of_mult t1 t2 = F.e_iop Formula.Imul t1 t2 + + let rec to_term (ai: 'a t) : 'a tint = match ai with + | AIcnst i -> term_of_cnst i + | AImult (i, t) -> term_of_mult (term_of_cnst i) t + | AIadd (t, i) -> term_of_add (to_term t) (term_of_cnst i) + | AIterm t -> t + + let cnst_is_zero i = 0 = Int64.compare i (Int64.zero) + + let is_zero ai = match ai with + | AIcnst i -> cnst_is_zero i + | _ -> false + + let add_cnst ai i = match ai with + | AIcnst i' when compute -> AIcnst (Int64.add i i') + | AIadd (t, i') when compute -> + AIadd (t, Int64.add i i') + | _ when cnst_is_zero i && compute -> ai + | _ -> AIadd (ai, i) + + let rec cnst_mult i ai = + if compute then match ai with + | AIcnst i' -> AIcnst (Int64.mul i i') + | AImult (i', t) -> AImult (Int64.mul i i', t) + | _ when cnst_is_zero i -> AIcnst Int64.zero + | AIadd (t, i') -> + add_cnst (cnst_mult i t) (Int64.mul i i') + | AIterm t -> AImult (i, t) + else of_term (term_of_mult (term_of_cnst i) (to_term ai)) + + let mult ai1 ai2 = match ai1, ai2 with + | AIcnst i1, _ -> cnst_mult i1 ai2 + | _, AIcnst i2 -> cnst_mult i2 ai1 + | AImult (i1, t1), AImult (i2, t2) when compute -> + cnst_mult (Int64.mul i1 i2) (AIterm (term_of_mult t1 t2)) + | _, _ -> (* TODO: develop other cases ? ) + let t1 = to_term ai1 in + let t2 = to_term ai2 in + AIterm (term_of_mult t1 t2) + + let rec add ai1 ai2 = match ai1, ai2 with + | AIcnst i1, _ -> add_cnst ai2 i1 + | _, AIcnst i2 -> add_cnst ai1 i2 + | AIadd (t1, i1), AIadd (t2, i2) when compute -> + add_cnst (add t1 t2) (Int64.add i1 i2) + | _, _ -> ( TODO: develop other cases ? ) + let t1 = to_term ai1 in + let t2 = to_term ai2 in + AIterm (term_of_add t1 t2) + + let sub ai1 ai2 = match ai1, ai2 with ( TODO: compute... ) + | _, _ -> + let t1 = to_term ai1 in + let t2 = to_term ai2 in + AIterm (term_of_sub t1 t2) + + let eq_cnst i1 i2 = 0 = Int64.compare i1 i2 + + let eq_pred ai1 ai2 = match ai1, ai2 with + | AIcnst i1, AIcnst i2 when compute -> + if eq_cnst i1 i2 then F.p_true else F.p_false + | _, _ -> ( TODO: develop other cases ? *) + F.p_eq (to_term ai1) (to_term ai2) + end + + (** Phantom types to tag the terms *) + type m_addr + type m_offset + type m_size + type m_zone + + (** Specialized type of F.integer terms ) + type t_addr = m_addr tint + type t_offset = m_offset tint + type t_size = m_size tint + type t_zone = m_zone F.term + + module Tint : sig + + type x_addr + val xaddr_of_var : mem_alloc -> varinfo -> x_addr + val xaddr_of_integer : F.integer -> x_addr + val integer_of_xaddr : x_addr -> F.integer + val varinfo_of_xaddr : x_addr -> varinfo option + val pp_addr : Format.formatter -> x_addr -> unit + val base : mem_alloc -> x_addr -> x_addr + val term_of_xaddr : x_addr -> t_addr + + type x_size + val size_of_int : int -> x_size + val size_of_int64 : Int64.t -> x_size + val cnst_mult_size : Int64.t -> x_size -> x_size + val xsize_of_range : F.integer -> F.integer -> x_size -> x_size + val term_of_xsize : x_size -> t_size + + val shift_n_elem : x_addr -> F.integer -> x_size -> x_addr + val shift_field : x_addr -> fieldinfo -> x_addr + + val toffset_of_field : ?mode:compute_int_mode -> fieldinfo -> t_offset + val tsize_of_field : ?mode:compute_int_mode -> fieldinfo -> t_size + + type x_zone + val mk_xzone : x_addr -> x_size -> x_zone + val xzone_of_var : mem_alloc -> varinfo -> x_size -> x_zone + val pp_xzone : Format.formatter -> x_zone -> unit + val term_of_xzone : x_zone -> m_zone F.term + val eq_zone : x_zone -> x_zone -> F.pred + val xzone_disj : x_zone -> x_zone -> F.pred + + end = struct + + (~*) + (** {2 Extracted specification from runtime.why} + * see definitions and axioms in + * {{:../../../share/why/runtime.why}runtime.why} + ) + module L = struct + let vaddr : mem_alloc -> F.name -> t_addr = F.e_app2 "rt_vaddr" + + let zone : t_addr -> t_size -> t_zone = F.e_app2 "rt_zone" + let vzone : mem_alloc -> F.name-> t_zone = F.e_app2 "rt_vzone" + + let foffset : F.name -> t_offset = F.e_app1 "rt_foffset" + let fsize : F.name -> t_size = F.e_app1 "rt_fsize" + + let shift : t_addr -> t_offset -> t_addr = F.e_app2 "rt_shift" + + let disj : t_zone -> t_zone -> F.pred = F.p_app2 "rt_disj" + + let base : mem_alloc -> t_addr -> t_addr = F.e_app2 "rt_abase" + end + + type x_addr = + | Lvaddr of (mem_alloc varinfo) + | Laddr of m_addr Aint.t + + type x_offset = m_offset Aint.t + type x_size = m_size Aint.t + type x_zone = + | Zterm of t_zone + | Zpair of x_addr * x_size + + let xaddr_of_var ma v = Lvaddr (ma, v) + + let term_of_xaddr ai : t_addr = match ai with + | Lvaddr (ma, v) -> L.vaddr ma (name_of_var v) + | Laddr ai -> Aint.to_term ai + + let aint_of_xaddr a : m_addr Aint.t = match a with + | Laddr a -> a + | _ -> Aint.of_term (term_of_xaddr a) + + let varinfo_of_xaddr a = match a with + | Lvaddr (_, vi) -> Some vi + | _ -> None + + let pp_addr fmt a = F.pp_term fmt (term_of_xaddr a) + + let xaddr_of_integer ti = Laddr (Aint.of_term ti) + let integer_of_xaddr xa = term_of_xaddr xa + + let base ma a = Laddr (Aint.of_term (L.base ma (term_of_xaddr a))) + + let offset_of_int i : x_offset = Aint.of_int i + let size_of_int sz : x_size = Aint.of_int sz + let size_of_int64 sz : x_size = Aint.of_int64 sz + let cnst_mult_size n (sz:x_size) : x_size = Aint.cnst_mult n sz + + let xsize_of_range min max sz = + let nb = Aint.sub (Aint.of_term max) (Aint.of_term min) in + let nb = Aint.add nb (Aint.of_int 1) in + Aint.mult nb sz + + let term_of_xsize ai : t_size = Aint.to_term ai + + let xoffset_of_field ?(mode=compute_int_mode) f = + if mode = CIMterms then + Aint.of_term (L.foffset (name_of_field f)) + else offset_of_int (cil_field_offset f) + + let toffset_of_field ?(mode=compute_int_mode) f = + Aint.to_term (xoffset_of_field ~mode f) + + let xsize_of_field ?(mode=compute_int_mode) f = + if mode = CIMterms then + Aint.of_term (L.fsize (name_of_field f)) + else size_of_int (cil_field_size f) + + let tsize_of_field ?(mode=compute_int_mode) f = + Aint.to_term (xsize_of_field ~mode f) + + let shift (a:x_addr) (offset:x_offset) : x_addr = + if compute_int_mode = CIMcompute then + Laddr (Aint.add (aint_of_xaddr a) offset) + else + Laddr (Aint.of_term + (L.shift (term_of_xaddr a) (Aint.to_term offset))) + + let shift_n_elem a n sz = + let o : x_offset = Aint.of_term n in + let o = Aint.mult sz o in + shift a o + + let shift_field a f = shift a (xoffset_of_field f) + + let xzone_of_var ma v sz = + if compute_int_mode = CIMterms then + Zterm (L.vzone ma (name_of_var v)) + else + Zpair (xaddr_of_var ma v, sz) + + let mk_xzone a sz : x_zone = match a with + | Lvaddr (ma, v) -> xzone_of_var ma v sz + | _ -> Zpair (a, sz) + + let term_of_xzone xz = match xz with + | Zterm t -> t + | Zpair (a, sz) -> L.zone (term_of_xaddr a) (term_of_xsize sz) + + let pp_xzone fmt xz = F.pp_term fmt (term_of_xzone xz) + + let eq_zone z1 z2 = (* TODO: SMP ) + F.p_eq (term_of_xzone z1) (term_of_xzone z2) + + let xzone_disj z1 z2 = ( TODO: SMP ) + L.disj (term_of_xzone z1) (term_of_xzone z2) + end + + ( open Tint ) + () + ( {3 about size and offset} ) + + let rec sizeof_c_object t : Tint.x_size = match t with + | Ctypes.C_comp comp -> + begin + try + let t = tcomp_of_comp comp in + let sz = Cil.bitsSizeOf t in + Tint.size_of_int sz + with Cil.SizeOfError (msg, t) -> + unsupported "sizeof %a : %s" !Ast_printer.d_type t msg + end + | Ctypes.C_array {Ctypes.arr_flat = Some flat} -> + let nb = flat.Ctypes.arr_cell_nbr in + let sz = sizeof_c_object (Ctypes.object_of flat.Ctypes.arr_cell) in + Tint.cnst_mult_size nb sz + | _ -> Tint.size_of_int64 (Ctypes.sizeof_object t) + + () + ( {2 Extracted specification from runtime.why} + * see definitions and axioms in + * {{:../../../share/why/runtime.why}runtime.why} + ) + + type m_bits + type t_bits = m_bits F.term + + type m_dzone + type dzone = m_dzone F.term + + module RtLib = struct + let rt_global : F.name -> F.pred = F.p_app1 "rt_global" + + let rt_vsize : F.name -> t_size = F.e_app1 "rt_vsize" + + ( let rt_vformat : F.name -> F.format = F.e_app1 "rt_vformat" + let rt_fformat : F.name -> F.format = F.e_app1 "rt_fformat" *) + + let load : mem_bits -> t_zone -> t_bits = F.e_app2 "rt_load" + let store : mem_bits -> t_addr -> t_bits -> mem_bits = F.e_app3 "rt_store" + let havoc : mem_bits -> t_zone -> mem_bits = F.e_app2 "rt_havoc" + + let to_bits : format -> F.abstract -> t_bits = F.e_app2 "rt_to_bits" + let from_bits : t_bits -> format -> F.abstract = F.e_app2 "rt_from_bits" + + let alloc : mem_alloc -> F.name -> mem_alloc = F.e_app2 "rt_valloc" + + let block_length : mem_alloc -> t_addr -> t_size + = F.e_app2 "rt_block_length" + let valid : mem_alloc -> t_zone -> F.pred = F.p_app2 "rt_valid" + + let is_havoc : mem_alloc -> mem_bits -> dzone -> mem_bits -> F.pred = + F.p_app4 "rt_is_havoc" + + let free : mem_alloc -> F.name -> mem_alloc = F.e_app2 "rt_vfree" + + let zs_empty : dzone = F.e_app0 "zs_empty" + let zs_singleton : t_zone -> dzone = F.e_app1 "zs_singleton" + let zs_union : dzone -> dzone -> dzone = F.e_app2 "zs_union" + let zs_incl : dzone -> dzone -> F.pred = F.p_app2 "zs_incl" + end + + let z_from_bits b fmt : F.integer = F.unwrap (RtLib.from_bits b fmt) + let real_from_bits b fmt : F.real = F.unwrap (RtLib.from_bits b fmt) + + () + + module Model = + struct + + module F = F + module A = A + module R = R + + type loc = Tint.x_addr + + let pp_loc fmt l = Tint.pp_addr fmt l + + let cast_loc_to_int _tp loc ti : F.integer = + let int_term = Tint.term_of_xaddr loc in + F.i_convert (Ctypes.c_ptr()) ti int_term + + + let cast_int_to_loc ti (i:F.integer) _tp : loc = + let i = F.i_convert ti (Ctypes.c_ptr()) i in + (Tint.xaddr_of_integer i) + + + let null = Tint.xaddr_of_integer F.i_zero + + let is_null l = + F.e_icmp Formula.Ceq (Tint.integer_of_xaddr l) F.i_zero + + let minus_loc l1 l2 = + F.e_app2 "rt_addr_minus" (Tint.term_of_xaddr l1) + (Tint.term_of_xaddr l2) + let le_loc_bool l1 l2 = + F.e_app2 "rt_addr_le_bool" (Tint.term_of_xaddr l1) + (Tint.term_of_xaddr l2) + let lt_loc_bool l1 l2 = + F.e_app2 "rt_addr_lt_bool" (Tint.term_of_xaddr l1) + (Tint.term_of_xaddr l2) + let equal_loc_bool l1 l2 = + F.e_app2 "rt_addr_eq_bool" (Tint.term_of_xaddr l1) + (Tint.term_of_xaddr l2) + let le_loc l1 l2 = F.p_app2 "rt_addr_le" (Tint.term_of_xaddr l1) + (Tint.term_of_xaddr l2) + let lt_loc l1 l2 = F.p_app2 "rt_addr_lt" (Tint.term_of_xaddr l1) + (Tint.term_of_xaddr l2) + let equal_loc l1 l2 = F.p_app2 "rt_addr_eq" (Tint.term_of_xaddr l1) + (Tint.term_of_xaddr l2) + + + let term_of_loc a = F.wrap (Tint.term_of_xaddr a) + let loc_of_term _ t = Tint.xaddr_of_integer (F.unwrap t) + + let tau_of_loc = Formula.Integer + + end + + let startof loc _ = loc + + let cast_loc_to_loc _t1 _t2 p = p + + () + (** {3 about zone} *) + (** + * Mwp requires a type [dzone] defined as [m_zone F.term] + * that represent why formula of the model why zone type + * (which name is given by [tau_of_zone] below). + * + * Because we need to provide function such as [dzone_union], + * this [dzone] is defined as a set of the [rt_zone] defined in WHY. + ) + + let tau_of_dzone = Formula.ADT("zones",[]) + + + let xzone_assigned = function + | F.Aloc( te , loc ) -> + Tint.mk_xzone loc (sizeof_c_object te) + | F.Arange( te , loc , rg ) -> + match rg with + | {F.inf = Some min; F.sup = Some max} -> + let sz = sizeof_c_object te in + let addr = Tint.shift_n_elem loc min sz in + let size = Tint.xsize_of_range min max sz in + Tint.mk_xzone addr size + | _ -> unsupported "unbounded range" + + let dzone_assigned _m a = RtLib.zs_singleton (Tint.term_of_xzone (xzone_assigned a)) + let dzone_empty () = RtLib.zs_empty + + let dzone_subset dz1 dz2 = RtLib.zs_incl dz1 dz2 + + let dzone_union dz1 dz2 = RtLib.zs_union dz1 dz2 + + let effect_supported = true + + + () + + let int_format_for_hyp t = match t with + | Ctypes.C_int cint -> Some (i_format cint) + | Ctypes.C_pointer ty -> Some (format_of_addr ty) + | _ -> None + + let add_int_format_hyp vformat t h = match int_format_for_hyp t with + | None -> h + | Some fmt -> + let h_format = F.p_eq vformat fmt in + F.p_and h_format h + + module VarDecl = F.DRegister + (struct + include F.Varinfo + + ( Global variable has a fixed zone in any allocation memory. + [forall ma, rt_vsize (ma, v) = sz /\ rt_vaddr (ma, v) = rt_gaddr v] ) + let declare v _ = + let t = Ctypes.object_of v.vtype in + let h = + if v.vglob then RtLib.rt_global (name_of_var v) + else F.p_true + in + let sz = sizeof_c_object t in + let size = RtLib.rt_vsize (name_of_var v) in + let h_size = F.p_eq size (Tint.term_of_xsize sz) in + let h = F.p_and h h_size in + ( let vformat = RtLib.rt_vformat (name_of_var v) in + let h = add_int_format_hyp vformat t h in ) + ( TODO: size info might be redondant with format... ) + ( TODO: format for other types... *) + Formula.Axiom h + + let section = Formula.S_Model_Prop + let prefix = "Decl" + let basename x = x.vname + let clear () = () + let pp_descr fmt _x = + Format.fprintf fmt "Global declaration" + end) + (**) + module Fields = F.DRegister + (struct + include F.Fieldinfo + + let declare f _ = + let foff = Tint.toffset_of_field ~mode:CIMterms f in + let off = Tint.toffset_of_field ~mode:CIMvalues f in + let hoff = F.p_eq foff off in + + let fsz = Tint.tsize_of_field ~mode:CIMterms f in + let sz = Tint.tsize_of_field ~mode:CIMvalues f in + let hsz = F.p_eq fsz sz in + let h = F.p_and hoff hsz in + + (* + let t = Ctypes.object_of f.ftype in + let fformat = RtLib.rt_fformat (name_of_field f) in + let h = add_int_format_hyp fformat t h in + ) + + Formula.Axiom h + + let section = Formula.S_Model_Prop + let prefix = "Finfo" + let basename x = + let name = F.Compinfo.basename x.fcomp in + (name^"_"^x.fname) + let clear () = () + let pp_descr fmt _x = + Format.fprintf fmt "Field info" + end) + () + module V = Datalib.Cvalues(Model) + module L = Datalib.Create(V) + + module Data = struct + include V + + type m_of_mem = m_mbits + + let tau_of_mem = t_mbits + + let forall_loc pool = + let p = F.p_fresh pool "p" (Formula.Model Formula.Integer) in + [p] , (Tint.xaddr_of_integer (F.var p)) + + + let global vi = VarDecl.define vi + + let cvar m vi = + VarDecl.define vi ; + Tint.xaddr_of_var (F.var m.valloc) vi + + let inner_loc _ = Wp_parameters.fatal "[inner_loc] reserved to funvar" + + let lvar _m lv x = + let ty = + match lv.lv_type with | Ctype ty -> ty | _ -> assert false + in + loc_of_term (Ctypes.object_of ty)(F.var x) + + let shift (l:loc) t i : loc = Tint.shift_n_elem l i (sizeof_c_object t) + + let index = shift + + ( Even if union field has 0 offset, we have to use on operation because + the size of the location to be consider might change from one field to + * another. *) + let field (l:loc) f = + Fields.define f; + Tint.shift_field l f + + let value_of_bits = ref (fun _ _ -> assert false) + let bits_of_value = ref (fun _ _ -> assert false) + + (** Read a data of type [te] at [loc] and returns it as a logic value. ) + let load_mem mb te loc = + let xzone = Tint.mk_xzone loc (sizeof_c_object te) in + let tzone = Tint.term_of_xzone xzone in + let bits = RtLib.load mb tzone in + (!value_of_bits te bits) + + let store_mem mb te loc v = + let tzone = Tint.term_of_xaddr loc in + RtLib.store mb tzone (!bits_of_value te v) + + end + + module DF = Data_mem.Create(Data) + + + + + + let load m te loc = + DF.loaded te; + Data.load_mem (F.var m.vbits) te loc + ( + match Tint.varinfo_of_xaddr loc (, logic_of_mem m ) with + | Some vi, Some tbl when vi.vformal -> + (* Pre state : vformal value is a logic variable + * which reprent the initial value of the parameter. ) + let v = + try Varinfo.Hashtbl.find tbl vi + with Not_found -> + let ct = Ctype vi.vtype in + let t = Data.tau_of_object (Ctypes.object_of vi.vtype) in + let v = L.fresh vi.vname (Formula.Acsl (t,ct)) in + (Varinfo.Hashtbl.add tbl vi v; v) + in (Data.value_of_logic te (F.var v)) + | _, _ -> + + ) + + let store m loc t exp_val = + DF.stored t; + Data.store_mem (F.var m.vbits) t loc exp_val + + include Data + + () + ( {3 about bits} + * [bits] type is used to represent the values that are stored in the memory. + * We have functions that encode/decode bits to/from ACSL logic values + * depending on the intermediate C type [t]. + * ) + + let format_of_compinfo comp = DF.record_format comp + ( if comp.cstruct then DF.record_format comp + else unsupported "format of union" *) + + let format_of_array arr = DF.array_format arr + + let rt_format_of_ctype t = match t with + | Ctypes.C_int c_int -> i_format c_int + | Ctypes.C_float c_float -> f_format c_float + | Ctypes.C_comp comp -> format_of_compinfo comp + | Ctypes.C_array arr -> format_of_array arr + | Ctypes.C_pointer ty -> format_of_addr ty + + (** Compute the logic value from bits interpreted with type [t]. ) + let rec value_of_bits t bits : Data.value = match t with + | Ctypes.C_int c_int -> + let c_val = z_from_bits bits (i_format c_int) in + V_int (c_int, c_val) + | Ctypes.C_float c_float -> + let ft = f_format c_float in + let c_val = real_from_bits bits ft in + V_float (c_float, c_val) + | Ctypes.C_comp comp -> + let ft = format_of_compinfo comp in + let c_val = RtLib.from_bits bits ft in + V_record (comp, F.unwrap c_val) + | Ctypes.C_array arr -> + let ft = format_of_array arr in + let c_val = RtLib.from_bits bits ft in + let logic_val = ( D.encode ft) (F.unwrap c_val) in + V_array (arr, F.unwrap logic_val) + | Ctypes.C_pointer ty -> + let cv = Ctypes.object_of ty in + let c_val = z_from_bits bits (format_of_addr cv) in + let addr = Tint.xaddr_of_integer c_val in + V_pointer (cv, addr) + + ( TODO: is it normal that we don't use t? + * Maybe we should check that it is the same than in the value ??? ) + let rec bits_of_value _t value : t_bits = match value with + | V_int (c_int, i) -> + let ft = i_format c_int in + RtLib.to_bits ft (F.wrap i) + | V_float (c_float, f) -> + let ft = f_format c_float in + RtLib.to_bits ft (F.wrap f) + | V_pointer (ty, loc) -> + let ft = format_of_addr ty in + RtLib.to_bits ft (F.wrap (Tint.integer_of_xaddr loc)) + | V_union _ -> unsupported "bits_of_value of union" + | V_record (comp, r) -> + let ft = format_of_compinfo comp in + let e = (D.decode ft) (F.wrap r) in + RtLib.to_bits ft e + | V_array (arr, t) -> + let ft = format_of_array arr in + let e = ( D.decode ft*) (F.wrap t) in + RtLib.to_bits ft e + + (** Horrible thing but no (known) way to avoid... ) + let () = + begin + Data.value_of_bits := value_of_bits ; + Data.bits_of_value := bits_of_value ; + end + () + + ( {3 Frame Environment} ) + + let mem ()= + let va = L.fresh "ma" (Formula.Model t_alloc) in + let vb = L.fresh "mb" (Formula.Model t_mbits) in + { vbits = vb ; valloc = va ;} + + (** {3 Validity }) + + let valid m a = + let xzone = xzone_assigned a in + RtLib.valid (F.var m.valloc) (Tint.term_of_xzone xzone) + + let separated _m z1 z2 = + Tint.xzone_disj (xzone_assigned z1) (xzone_assigned z2) + + let tbits_of_var a : t_bits = F.var a + + let subst_havoc m a = + let xzone = xzone_assigned a in + ( let v = L.fresh "v" (Mdata.Vmodel(Formula.ADT("bits",[]))) in + let bits = tbits_of_var v in *) + let new_vmh sigma = + let mb = L.apply sigma (F.var m.vbits) in + F.wrap (RtLib.havoc mb (Tint.term_of_xzone xzone)) + in + [F.Update( m.vbits, new_vmh)] + + let assigns_goal m1 region m2 = + let zones = + match region with + | [] -> dzone_empty () + | [a] -> dzone_assigned m1 a + | a::others -> + List.fold_left + (fun dz a -> + dzone_union dz (dzone_assigned m1 a) + ) (dzone_assigned m1 a) others + in + RtLib.is_havoc (F.var m1.valloc) (F.var m1.vbits) zones (F.var m2.vbits) + + let assigns_supported = true + + (** {3 Special locations} ) + + let base_address m loc = Tint.base (F.var m.valloc) loc + + let block_length m p = + RtLib.block_length (F.var m.valloc) (Tint.term_of_xaddr p) + + () + ( {3 User-defined Predicates} ) + + type closure = + | Mem + | Alloc + + let pp_closure fmt = function + | Mem ->Format.fprintf fmt "memory store" + | Alloc ->Format.fprintf fmt "allocation table" + + let userdef_mem_signature m = [m.vbits,Mem ; m.valloc,Alloc] + + let userdef_mem_apply m cl = match cl with + | Mem -> F.wrap (F.var m.vbits) + | Alloc -> F.wrap (F.var m.valloc) + + (* ------------------------------------------------------------------------ ) + ( --- Functional Closure --- ) + ( ------------------------------------------------------------------------ ) + + type formal = unit + let pp_formal _ _ = () + let userdef_is_ref_param (_:logic_var): bool = false + let userdef_ref_signature (_:mem) : ( F.var logic_var * formal ) list = [] + let userdef_ref_apply (_:mem) (_:formal) (_:loc) : value = assert false + let userdef_ref_has_cvar (_ : logic_var) : bool = false + + + (~~) + (** {2 Mwp.S requirements} ) + + let update ~(at:mem) ~(here:mem) p = + let p = L.subst at.vbits (F.var here.vbits) p in + let p = L.subst at.valloc (F.var here.valloc) p in + p + + let quantify m p = + L.forall [m.vbits;m.valloc] p + + let subst_lval m t ptr exp p = + let s = F.wrap (store m ptr t exp) in + L.subst m.vbits s p + + ( ------------------------------------------------------------------------ ) + ( --- Local Scope --- ) + ( ------------------------------------------------------------------------ ) + + let local_scope m vars scope_kind p = + let vmh = m.vbits in + let mh = F.var vmh in + let do_var p v = + let alloc v p = + Wp_parameters.debug ~dkey "[local_scope] alloc %s@." v.vname; + let ma = RtLib.alloc mh (name_of_var v) in + let p = L.subst vmh ma p in + p + in +( + let init v p = (* initialize parameter : v@Here = v@Pre ) + let m_pre = mem_at env Clabels.Pre in + let v_loc = cvar m_here v in + let v_pre = load m_pre t v_loc in + let p = subst_lval env t v_loc v_pre p in + p + in +) + let p = match scope_kind with + | Mcfg.SC_Function_in -> + let p = alloc v p in p + (* + let p = match logic_of_mem (mem_at env Clabels.Pre) with + | None -> p + | Some tbl -> + try let lv = Varinfo.Hashtbl.find tbl v in + L.forall [lv] p + with Not_found -> p + in p ) + | Mcfg.SC_Function_frame -> + ( let p = init v p in ) + let p = alloc v p in + p + | Mcfg.SC_Block_in -> + let p = alloc v p in + (let h = add_int_format_hyp (name_of_var v) t F.p_true in + F.p_implies h p + ) p + | Mcfg.SC_Block_out | Mcfg.SC_Function_out -> + Wp_parameters.debug ~dkey "[local_scope] free %s@." v.vname; + L.subst vmh (RtLib.free mh (name_of_var v)) p + | Mcfg.SC_Global -> ( nothing to do ) p + in p + in List.fold_left do_var p vars + + let global_scope _ p = p + +end + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/runtime_mem.mli frama-c-20111001+nitrogen+dfsg/src/wp/runtime_mem.mli --- frama-c-20110201+carbon+dfsg/src/wp/runtime_mem.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/runtime_mem.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,30 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( ) +() + +module Create + (F:Formula.S) + (A:Mint.S with module F = F) + (R:Mfloat.S with module F = F) + : + Mwp.S with module F = F + and module A = A + and module R = R diff -Nru frama-c-20110201+carbon+dfsg/src/wp/script.ml frama-c-20111001+nitrogen+dfsg/src/wp/script.ml --- frama-c-20110201+carbon+dfsg/src/wp/script.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/script.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,475 @@ +() +( ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( ) +() + +# 23 "src/wp/script.mll" + + + type token = + | Id of string + | Key of string + | Proof of string + | Word + | Eof + + let keywords = [ "Goal" ; "Hint" ] + + let fill buffer lexbuf = + Buffer.add_string buffer (Lexing.lexeme lexbuf) + + open Lexing + + let newline lexbuf = + lexbuf.lex_curr_p <- + { lexbuf.lex_curr_p with pos_lnum = succ lexbuf.lex_curr_p.pos_lnum } + + +# 24 "src/wp/script.ml" +let __ocaml_lex_tables = { + Lexing.lex_base = + "\000\000\246\255\248\255\000\000\250\255\075\000\160\000\254\255\ + \002\000\235\000\054\001\129\001\206\001\007\000\253\255\249\255\ + \105\001\251\255\252\255\253\255\001\000\000\000\255\255\254\255\ + \106\001\250\255\251\255\252\255\004\000\005\000\036\000\033\000\ + \035\000\014\000\255\255\018\000\036\000\015\000\254\255\253\255\ + "; + Lexing.lex_backtrk = + "\255\255\255\255\255\255\009\000\255\255\004\000\004\000\255\255\ + \000\000\004\000\004\000\004\000\004\000\003\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\004\000\004\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\005\000\005\000\005\000\005\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + "; + Lexing.lex_default = + "\001\000\000\000\000\000\255\255\000\000\255\255\255\255\000\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\000\000\000\000\ + \017\000\000\000\000\000\000\000\255\255\255\255\000\000\000\000\ + \025\000\000\000\000\000\000\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\000\000\255\255\255\255\255\255\000\000\000\000\ + "; + Lexing.lex_trans = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\008\000\007\000\008\000\000\000\008\000\000\000\008\000\ + \013\000\014\000\000\000\000\000\013\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \008\000\000\000\008\000\000\000\000\000\000\000\000\000\013\000\ + \003\000\022\000\015\000\023\000\004\000\039\000\004\000\038\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\004\000\004\000\034\000\034\000\000\000\000\000\ + \000\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \006\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\000\000\000\000\000\000\000\000\005\000\ + \000\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\035\000\032\000\033\000\ + \036\000\037\000\000\000\000\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\000\000\000\000\ + \000\000\000\000\005\000\000\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\000\000\000\000\000\000\000\000\005\000\ + \002\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\009\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\000\000\000\000\ + \000\000\000\000\005\000\000\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\010\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \000\000\000\000\000\000\018\000\026\000\000\000\000\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\020\000\029\000\021\000\028\000\005\000\000\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\011\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\031\000\000\000\030\000\000\000\000\000\ + \000\000\000\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\000\000\000\000\000\000\000\000\ + \005\000\000\000\005\000\005\000\005\000\005\000\005\000\012\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\013\000\000\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\000\000\000\000\000\000\000\000\005\000\000\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\019\000\027\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000"; + Lexing.lex_check = + "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\008\000\255\255\000\000\255\255\008\000\ + \013\000\013\000\255\255\255\255\013\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \000\000\255\255\008\000\255\255\255\255\255\255\255\255\013\000\ + \000\000\021\000\003\000\020\000\000\000\028\000\000\000\029\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\033\000\037\000\255\255\255\255\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\255\255\255\255\255\255\255\255\000\000\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\030\000\031\000\032\000\ + \035\000\036\000\255\255\255\255\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\255\255\255\255\ + \255\255\255\255\005\000\255\255\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ + \005\000\005\000\005\000\005\000\005\000\005\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\255\255\255\255\255\255\255\255\006\000\ + \000\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\006\000\009\000\009\000\009\000\009\000\009\000\ + \009\000\009\000\009\000\009\000\009\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\009\000\009\000\009\000\009\000\ + \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ + \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ + \009\000\009\000\009\000\009\000\009\000\009\000\255\255\255\255\ + \255\255\255\255\009\000\255\255\009\000\009\000\009\000\009\000\ + \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ + \009\000\009\000\009\000\009\000\009\000\009\000\009\000\009\000\ + \009\000\009\000\009\000\009\000\009\000\009\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \255\255\255\255\255\255\016\000\024\000\255\255\255\255\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\016\000\024\000\016\000\024\000\010\000\255\255\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ + \010\000\011\000\011\000\011\000\011\000\011\000\011\000\011\000\ + \011\000\011\000\011\000\024\000\255\255\024\000\255\255\255\255\ + \255\255\255\255\011\000\011\000\011\000\011\000\011\000\011\000\ + \011\000\011\000\011\000\011\000\011\000\011\000\011\000\011\000\ + \011\000\011\000\011\000\011\000\011\000\011\000\011\000\011\000\ + \011\000\011\000\011\000\011\000\255\255\255\255\255\255\255\255\ + \011\000\255\255\011\000\011\000\011\000\011\000\011\000\011\000\ + \011\000\011\000\011\000\011\000\011\000\011\000\011\000\011\000\ + \011\000\011\000\011\000\011\000\011\000\011\000\011\000\011\000\ + \011\000\011\000\011\000\011\000\012\000\255\255\012\000\012\000\ + \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\012\000\ + \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ + \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ + \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ + \012\000\255\255\255\255\255\255\255\255\012\000\255\255\012\000\ + \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ + \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ + \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ + \012\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\016\000\024\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255"; + Lexing.lex_base_code = + ""; + Lexing.lex_backtrk_code = + ""; + Lexing.lex_default_code = + ""; + Lexing.lex_trans_code = + ""; + Lexing.lex_check_code = + ""; + Lexing.lex_code = + ""; +} + +let rec token lexbuf = + __ocaml_lex_token_rec lexbuf 0 +and __ocaml_lex_token_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 48 "src/wp/script.mll" + ( token lexbuf ) +# 250 "src/wp/script.ml" + + | 1 -> +# 49 "src/wp/script.mll" + ( newline lexbuf ; token lexbuf ) +# 255 "src/wp/script.ml" + + | 2 -> +# 51 "src/wp/script.mll" + ( + newline lexbuf ; + let buffer = Buffer.create 512 in + proof buffer 0 lexbuf ; + Proof (Buffer.contents buffer) + ) +# 265 "src/wp/script.ml" + + | 3 -> +# 58 "src/wp/script.mll" + ( + let buffer = Buffer.create 512 in + proof buffer 0 lexbuf ; + Proof (Buffer.contents buffer) + ) +# 274 "src/wp/script.ml" + + | 4 -> +# 64 "src/wp/script.mll" + ( + let a = Lexing.lexeme lexbuf in + if List.mem a keywords then Key a else Id a + ) +# 282 "src/wp/script.ml" + + | 5 -> +# 68 "src/wp/script.mll" + ( Key(Lexing.lexeme lexbuf) ) +# 287 "src/wp/script.ml" + + | 6 -> +# 69 "src/wp/script.mll" + ( comment 0 lexbuf ) +# 292 "src/wp/script.ml" + + | 7 -> +# 70 "src/wp/script.mll" + ( Eof ) +# 297 "src/wp/script.ml" + + | 8 -> +# 71 "src/wp/script.mll" + ( Key(Lexing.lexeme lexbuf) ) +# 302 "src/wp/script.ml" + + | 9 -> +# 72 "src/wp/script.mll" + ( Word ) +# 307 "src/wp/script.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state + +and comment n lexbuf = + __ocaml_lex_comment_rec n lexbuf 16 +and __ocaml_lex_comment_rec n lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 75 "src/wp/script.mll" + ( if n > 0 then comment (pred n) lexbuf else token lexbuf ) +# 318 "src/wp/script.ml" + + | 1 -> +# 76 "src/wp/script.mll" + ( comment (succ n) lexbuf ) +# 323 "src/wp/script.ml" + + | 2 -> +# 77 "src/wp/script.mll" + ( failwith "Non-terminated comment" ) +# 328 "src/wp/script.ml" + + | 3 -> +# 78 "src/wp/script.mll" + ( newline lexbuf ; comment n lexbuf ) +# 333 "src/wp/script.ml" + + | 4 -> +# 79 "src/wp/script.mll" + ( comment n lexbuf ) +# 338 "src/wp/script.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec n lexbuf __ocaml_lex_state + +and proof buffer n lexbuf = + __ocaml_lex_proof_rec buffer n lexbuf 24 +and __ocaml_lex_proof_rec buffer n lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 83 "src/wp/script.mll" + ( + if n > 0 then proof buffer (pred n) lexbuf + ) +# 351 "src/wp/script.ml" + + | 1 -> +# 86 "src/wp/script.mll" + ( fill buffer lexbuf ; proof buffer (succ n) lexbuf ) +# 356 "src/wp/script.ml" + + | 2 -> +# 87 "src/wp/script.mll" + ( fill buffer lexbuf ; + if n>0 then proof buffer (pred n) lexbuf + else failwith "Non-terminated comment (inside proof)" ) +# 363 "src/wp/script.ml" + + | 3 -> +# 90 "src/wp/script.mll" + ( failwith "Non-terminated proof" ) +# 368 "src/wp/script.ml" + + | 4 -> +# 91 "src/wp/script.mll" + ( fill buffer lexbuf ; newline lexbuf ; proof buffer n lexbuf ) +# 373 "src/wp/script.ml" + + | 5 -> +# 92 "src/wp/script.mll" + ( fill buffer lexbuf ; proof buffer n lexbuf ) +# 378 "src/wp/script.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_proof_rec buffer n lexbuf __ocaml_lex_state + +;; + +# 94 "src/wp/script.mll" + + + type input = { + src : string ; + inc : in_channel ; + lexbuf : Lexing.lexbuf ; + mutable token : token ; + mutable tik : int ; + } + + let open_file f = + let inc = open_in f in + let lex = Lexing.from_channel inc in + let tok = token lex in + { src=f ; tik=0 ; inc=inc ; lexbuf=lex ; token=tok } + + let pp_token lexbuf fmt = function + | Id x -> Format.fprintf fmt "ident '%s'" x + | Key k -> Format.fprintf fmt "'%s'" k + | Proof _ -> Format.fprintf fmt "Proof...Qed" + | Eof -> Format.fprintf fmt "end-of-file" + | Word -> Format.fprintf fmt "start of '%s'" (Lexing.lexeme lexbuf) + + + let skip input = + if input.token <> Eof then + ( input.tik <- 0 ; input.token <- token input.lexbuf ) + let token input = + input.tik <- succ input.tik ; + if input.tik > 1000 then failwith "Blocked" ; + input.token + let close input = close_in input.inc + let error input text = + let buffer = Buffer.create 80 in + let fmt = Format.formatter_of_buffer buffer in + let line = (Lexing.lexeme_start_p input.lexbuf).Lexing.pos_lnum in + Format.fprintf fmt "%s:%d: " input.src line ; + Format.kfprintf + (fun fmt -> + Format.fprintf fmt "(at %a)" (pp_token input.lexbuf) input.token ; + Format.pp_print_flush fmt () ; + failwith (Buffer.contents buffer) + ) fmt text + + let eraise input = function + | Failure msg -> error input "Failure '%s'" msg + | exn -> error input "Failure '%s'" (Printexc.to_string exn) + + let key input k = + match input.token with + | Key a when a=k -> skip input ; true + | _ -> false + + let eat input k = + if not (key input k) then error input "Missing '%s'" k + + let ident input = + match input.token with + | Id a -> skip input ; a + | _ -> error input "Missing identifier" + + let rec idents input = + match input.token with + | Id a -> + skip input ; + if key input "," then a :: idents input else [a] + | _ -> [] + + +# 454 "src/wp/script.ml" diff -Nru frama-c-20110201+carbon+dfsg/src/wp/script.mli frama-c-20111001+nitrogen+dfsg/src/wp/script.mli --- frama-c-20110201+carbon+dfsg/src/wp/script.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/script.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,45 @@ +() +( ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Lexer for Script files --- ) +( -------------------------------------------------------------------------- *) + +type token = + | Id of string + | Key of string + | Proof of string + | Word + | Eof + +type input + +val open_file : string -> input +val close : input -> unit +val skip : input -> unit +val token : input -> token +val error : input -> ('a,Format.formatter,unit,'b) format4 -> 'a + +val key : input -> string -> bool +val eat : input -> string -> unit +val ident : input -> string +val idents : input -> string list diff -Nru frama-c-20110201+carbon+dfsg/src/wp/script.mll frama-c-20111001+nitrogen+dfsg/src/wp/script.mll --- frama-c-20110201+carbon+dfsg/src/wp/script.mll 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/script.mll 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,162 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +{ + + type token = + | Id of string + | Key of string + | Proof of string + | Word + | Eof + + let keywords = [ "Goal" ; "Hint" ] + + let fill buffer lexbuf = + Buffer.add_string buffer (Lexing.lexeme lexbuf) + + open Lexing + + let newline lexbuf = + lexbuf.lex_curr_p <- + { lexbuf.lex_curr_p with pos_lnum = succ lexbuf.lex_curr_p.pos_lnum } + +} + +let space = [' ' '\t' '\r'] + +rule token = parse + space+ { token lexbuf } + | '\n' { newline lexbuf ; token lexbuf } + | "Proof." space* '\n' + { + newline lexbuf ; + let buffer = Buffer.create 512 in + proof buffer 0 lexbuf ; + Proof (Buffer.contents buffer) + } + | "Proof." space* + { + let buffer = Buffer.create 512 in + proof buffer 0 lexbuf ; + Proof (Buffer.contents buffer) + } + | [ 'a'-'z' 'A'-'Z' '0'-'9' '_' ]+ + { + let a = Lexing.lexeme lexbuf in + if List.mem a keywords then Key a else Id a + } + | [ '.' ':' ',' ';' ] { Key(Lexing.lexeme lexbuf) } + | "(" { comment 0 lexbuf } + | eof { Eof } + | [ ',' '.' ] { Key(Lexing.lexeme lexbuf) } + | _ { Word } + +and comment n = parse + ")" { if n > 0 then comment (pred n) lexbuf else token lexbuf } + | "(" { comment (succ n) lexbuf } + | eof { failwith "Non-terminated comment" } + | '\n' { newline lexbuf ; comment n lexbuf } + | _ { comment n lexbuf } + +and proof buffer n = parse + ( "Qed." | "Save." ) + { + if n > 0 then proof buffer (pred n) lexbuf + } + | "(" { fill buffer lexbuf ; proof buffer (succ n) lexbuf } + | ")" { fill buffer lexbuf ; + if n>0 then proof buffer (pred n) lexbuf + else failwith "Non-terminated comment (inside proof)" } + | eof { failwith "Non-terminated proof" } + | '\n' { fill buffer lexbuf ; newline lexbuf ; proof buffer n lexbuf } + | _ { fill buffer lexbuf ; proof buffer n lexbuf } + +{ + + type input = { + src : string ; + inc : in_channel ; + lexbuf : Lexing.lexbuf ; + mutable token : token ; + mutable tik : int ; + } + + let open_file f = + let inc = open_in f in + let lex = Lexing.from_channel inc in + let tok = token lex in + { src=f ; tik=0 ; inc=inc ; lexbuf=lex ; token=tok } + + let pp_token lexbuf fmt = function + | Id x -> Format.fprintf fmt "ident '%s'" x + | Key k -> Format.fprintf fmt "'%s'" k + | Proof _ -> Format.fprintf fmt "Proof...Qed" + | Eof -> Format.fprintf fmt "end-of-file" + | Word -> Format.fprintf fmt "start of '%s'" (Lexing.lexeme lexbuf) + + + let skip input = + if input.token <> Eof then + ( input.tik <- 0 ; input.token <- token input.lexbuf ) + let token input = + input.tik <- succ input.tik ; + if input.tik > 1000 then failwith "Blocked" ; + input.token + let close input = close_in input.inc + let error input text = + let buffer = Buffer.create 80 in + let fmt = Format.formatter_of_buffer buffer in + let line = (Lexing.lexeme_start_p input.lexbuf).Lexing.pos_lnum in + Format.fprintf fmt "%s:%d: " input.src line ; + Format.kfprintf + (fun fmt -> + Format.fprintf fmt "(at %a)" (pp_token input.lexbuf) input.token ; + Format.pp_print_flush fmt () ; + failwith (Buffer.contents buffer) + ) fmt text + + let eraise input = function + | Failure msg -> error input "Failure '%s'" msg + | exn -> error input "Failure '%s'" (Printexc.to_string exn) + + let key input k = + match input.token with + | Key a when a=k -> skip input ; true + | _ -> false + + let eat input k = + if not (key input k) then error input "Missing '%s'" k + + let ident input = + match input.token with + | Id a -> skip input ; a + | _ -> error input "Missing identifier" + + let rec idents input = + match input.token with + | Id a -> + skip input ; + if key input "," then a :: idents input else [a] + | _ -> [] + +} diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/hoare_ergo.why frama-c-20111001+nitrogen+dfsg/src/wp/share/hoare_ergo.why --- frama-c-20110201+carbon+dfsg/src/wp/share/hoare_ergo.why 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/hoare_ergo.why 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,904 @@ +logic eq_unit : unit,unit -> prop + +logic neq_unit : unit,unit -> prop + +logic eq_bool : bool,bool -> prop + +logic neq_bool : bool,bool -> prop + +logic lt_int : int,int -> prop + +logic le_int : int,int -> prop + +logic gt_int : int,int -> prop + +logic ge_int : int,int -> prop + +logic eq_int : int,int -> prop + +logic neq_int : int,int -> prop + +logic add_int : int,int -> int + +logic sub_int : int,int -> int + +logic mul_int : int,int -> int + +logic neg_int : int -> int + +predicate zwf_zero(a:int,b:int) = ((0<=b) and (a<b)) + +logic bool_and : bool,bool -> bool + +logic bool_or : bool,bool -> bool + +logic bool_xor : bool,bool -> bool + +logic bool_not : bool -> bool + +axiom bool_and_def : (forall a:bool.(forall b:bool. +((bool_and(a,b)=true) <-> ((a=true) and (b=true))))) + +axiom bool_or_def : (forall a:bool.(forall b:bool. +((bool_or(a,b)=true) <-> ((a=true) or (b=true))))) + +axiom bool_xor_def : (forall a:bool.(forall b:bool. +((bool_xor(a,b)=true) <-> (a<>b)))) + +axiom bool_not_def : (forall a:bool. +((bool_not(a)=true) <-> (a=false))) + +logic ite : bool,'a1,'a1 -> 'a1 + +axiom ite_true : (forall x:'a1.(forall y:'a1. +(ite(true,x,y)=x))) + +axiom ite_false : (forall x:'a1.(forall y:'a1. +(ite(false,x,y)=y))) + +logic lt_int_bool : int,int -> bool + +logic le_int_bool : int,int -> bool + +logic gt_int_bool : int,int -> bool + +logic ge_int_bool : int,int -> bool + +logic eq_int_bool : int,int -> bool + +logic neq_int_bool : int,int -> bool + +axiom lt_int_bool_axiom : (forall x:int.(forall y:int. +((lt_int_bool(x,y)=true) <-> (x<y)))) + +axiom le_int_bool_axiom : (forall x:int.(forall y:int. +((le_int_bool(x,y)=true) <-> (x<=y)))) + +axiom gt_int_bool_axiom : (forall x:int.(forall y:int. +((gt_int_bool(x,y)=true) <-> (x>y)))) + +axiom ge_int_bool_axiom : (forall x:int.(forall y:int. +((ge_int_bool(x,y)=true) <-> (x>=y)))) + +axiom eq_int_bool_axiom : (forall x:int.(forall y:int. +((eq_int_bool(x,y)=true) <-> (x=y)))) + +axiom neq_int_bool_axiom : (forall x:int.(forall y:int. +((neq_int_bool(x,y)=true) <-> (x<>y)))) + +logic abs_int : int -> int + +axiom abs_int_pos : (forall x:int. +((x>=0) -> (abs_int(x)=x))) + +axiom abs_int_neg : (forall x:int. +((x<=0) -> (abs_int(x)=(-x)))) + +logic int_max : int,int -> int + +logic int_min : int,int -> int + +axiom int_max_is_ge : (forall x:int.(forall y:int. +((int_max(x,y)>=x) and (int_max(x,y)>=y)))) + +axiom int_max_is_some : (forall x:int.(forall y:int. +((int_max(x,y)=x) or (int_max(x,y)=y)))) + +axiom int_min_is_le : (forall x:int.(forall y:int. +((int_min(x,y)<=x) and (int_min(x,y)<=y)))) + +axiom int_min_is_some : (forall x:int.(forall y:int. +((int_min(x,y)=x) or (int_min(x,y)=y)))) + +logic lt_real : real,real -> prop + +logic le_real : real,real -> prop + +logic gt_real : real,real -> prop + +logic ge_real : real,real -> prop + +logic eq_real : real,real -> prop + +logic neq_real : real,real -> prop + +logic add_real : real,real -> real + +logic sub_real : real,real -> real + +logic mul_real : real,real -> real + +logic div_real : real,real -> real + +logic neg_real : real -> real + +logic real_of_int : int -> real + +axiom real_of_int_zero : (real_of_int(0)=0.0) + +axiom real_of_int_one : (real_of_int(1)=1.0) + +axiom real_of_int_add : (forall x:int.(forall y:int. +(real_of_int((x+y))=(real_of_int(x)+real_of_int(y))))) + +axiom real_of_int_sub : (forall x:int.(forall y:int. +(real_of_int((x-y))=(real_of_int(x)-real_of_int(y))))) + +logic truncate_real_to_int : real -> int + +axiom truncate_down_pos : (forall x:real. +((x>=0.0) -> ((real_of_int(truncate_real_to_int(x))<=x) and (x<real_of_int((truncate_real_to_int(x)+1)))))) + +axiom truncate_up_neg : (forall x:real. +((x<=0.0) -> ((real_of_int((truncate_real_to_int(x)-1))<x) and (x<=real_of_int(truncate_real_to_int(x)))))) + +logic floor_real_to_int : real -> int + +logic ceil_real_to_int : real -> int + +logic lt_real_bool : real,real -> bool + +logic le_real_bool : real,real -> bool + +logic gt_real_bool : real,real -> bool + +logic ge_real_bool : real,real -> bool + +logic eq_real_bool : real,real -> bool + +logic neq_real_bool : real,real -> bool + +axiom lt_real_bool_axiom : (forall x:real.(forall y:real. +((lt_real_bool(x,y)=true) <-> (x<y)))) + +axiom le_real_bool_axiom : (forall x:real.(forall y:real. +((le_real_bool(x,y)=true) <-> (x<=y)))) + +axiom gt_real_bool_axiom : (forall x:real.(forall y:real. +((gt_real_bool(x,y)=true) <-> (x>y)))) + +axiom ge_real_bool_axiom : (forall x:real.(forall y:real. +((ge_real_bool(x,y)=true) <-> (x>=y)))) + +axiom eq_real_bool_axiom : (forall x:real.(forall y:real. +((eq_real_bool(x,y)=true) <-> (x=y)))) + +axiom neq_real_bool_axiom : (forall x:real.(forall y:real. +((neq_real_bool(x,y)=true) <-> (x<>y)))) + +logic real_max : real,real -> real + +logic real_min : real,real -> real + +axiom real_max_is_ge : (forall x:real.(forall y:real. +((real_max(x,y)>=x) and (real_max(x,y)>=y)))) + +axiom real_max_is_some : (forall x:real.(forall y:real. +((real_max(x,y)=x) or (real_max(x,y)=y)))) + +axiom real_min_is_le : (forall x:real.(forall y:real. +((real_min(x,y)<=x) and (real_min(x,y)<=y)))) + +axiom real_min_is_some : (forall x:real.(forall y:real. +((real_min(x,y)=x) or (real_min(x,y)=y)))) + +function sqr_real(x:real) : real = (xx) + +logic sqrt_real : real -> real + +axiom sqrt_pos : (forall x:real. +((x>=0.0) -> (sqrt_real(x)>=0.0))) + +axiom sqrt_sqr : (forall x:real. +((x>=0.0) -> (sqr_real(sqrt_real(x))=x))) + +axiom sqr_sqrt : (forall x:real. +((x>=0.0) -> (sqrt_real((xx))=x))) + +logic pow_real : real,real -> real + +logic abs_real : real -> real + +axiom abs_real_pos : (forall x:real[abs_real(x)]. +((x>=0.0) -> (abs_real(x)=x))) + +axiom abs_real_neg : (forall x:real[abs_real(x)]. +((x<=0.0) -> (abs_real(x)=(-x)))) + +logic exp : real -> real + +logic log : real -> real + +logic log10 : real -> real + +axiom log_exp : (forall x:real. +(log(exp(x))=x)) + +axiom exp_log : (forall x:real. +((x>0.0) -> (exp(log(x))=x))) + +logic cos : real -> real + +logic sin : real -> real + +logic tan : real -> real + +logic pi : real + +logic cosh : real -> real + +logic sinh : real -> real + +logic tanh : real -> real + +logic acos : real -> real + +logic asin : real -> real + +logic atan : real -> real + +logic atan2 : real,real -> real + +logic hypot : real,real -> real + +axiom prod_pos : (forall x:real.(forall y:real. +((((x>0.0) and (y>0.0)) -> ((xy)>0.0)) and (((x<0.0) and (y<0.0)) -> ((xy)>0.0))))) + +axiom abs_minus : (forall x:real. +(abs_real((-x))=abs_real(x))) + + +logic access : 'a1 farray,int -> 'a1 + +logic update : 'a1 farray,int,'a1 -> 'a1 farray + +axiom access_update : (forall a:'a1 farray.(forall i:int.(forall v:'a1. +(a[i<-v][i]=v)))) + +axiom access_update_neq : (forall a:'a1 farray.(forall i:int.(forall j:int. +(forall v:'a1. +((i<>j) -> (a[i<-v][j]=a[j])))))) + +logic array_length : 'a1 farray -> int + +predicate sorted_array(t:int farray,i:int,j:int) = (forall k1:int. +(forall k2:int. +((((i<=k1) and (k1<=k2)) and (k2<=j)) -> (t[k1]<=t[k2])))) + +predicate exchange(a1:'a1 farray,a2:'a1 farray,i:int,j:int) = ((array_length(a1)=array_length(a2)) and ((a1[i]=a2[j]) and ((a2[i]=a1[j]) and ( +forall k:int. +(((k<>i) and (k<>j)) -> (a1[k]=a2[k])))))) + +logic permut : 'a1 farray,'a1 farray,int,int -> prop + +axiom permut_refl : (forall t:'a1 farray.(forall l:int.(forall u:int. +permut(t,t,l, +u)))) + +axiom permut_sym : (forall t1:'a1 farray.(forall t2:'a1 farray.(forall l:int. +(forall u:int.(permut(t1,t2,l,u) -> permut(t2,t1,l, +u)))))) + +axiom permut_trans : (forall t1:'a1 farray.(forall t2:'a1 farray. +(forall t3:'a1 farray.(forall l:int.(forall u:int.(permut(t1,t2,l, +u) -> (permut(t2,t3,l,u) -> permut(t1,t3,l, +u)))))))) + +axiom permut_exchange : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l:int.(forall u:int.(forall i:int.(forall j:int. +(((l<=i) and (i<=u)) -> (((l<=j) and (j<=u)) -> (exchange(a1,a2,i, +j) -> permut(a1,a2,l, +u)))))))))) + +axiom exchange_upd : (forall a:'a1 farray.(forall i:int.(forall j:int. +exchange(a,a[i<-a[j]][j<-a[i]],i, +j)))) + +axiom permut_weakening : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l1:int.(forall r1:int.(forall l2:int.(forall r2:int. +((((l1<=l2) and (l2<=r2)) and (r2<=r1)) -> (permut(a1,a2,l2,r2) -> permut(a1, +a2,l1, +r1))))))))) + +axiom permut_eq : (forall a1:'a1 farray.(forall a2:'a1 farray.(forall l:int. +(forall u:int.((l<=u) -> (permut(a1,a2,l,u) -> (forall i:int. +(((i<l) or (u<i)) -> (a2[i]=a1[i]))))))))) + +predicate permutation(a1:'a1 farray,a2:'a1 farray) = permut(a1,a2,0, +(array_length(a1)-1)) + +axiom array_length_update : (forall a:'a1 farray.(forall i:int.(forall v:'a1. +(array_length(a[i<-v])=array_length(a))))) + +axiom permut_array_length : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l:int.(forall u:int.(permut(a1,a2,l, +u) -> (array_length(a1)=array_length(a2))))))) + +logic computer_div : int,int -> int + +logic computer_mod : int,int -> int + +logic math_div : int,int -> int + +logic math_mod : int,int -> int + +axiom math_div_mod : (forall x:int.(forall y:int. +((y<>0) -> (x=((ymath_div(x,y))+math_mod(x,y)))))) + +axiom math_mod_bound : (forall x:int.(forall y:int. +((y<>0) -> ((0<=math_mod(x,y)) and (math_mod(x,y)<abs_int(y)))))) + +axiom computer_div_mod : (forall x:int. +(forall y:int[computer_div(x,y),computer_mod(x,y)]. +((y<>0) -> (x=((ycomputer_div(x,y))+computer_mod(x,y)))))) + +axiom computer_div_bound : (forall x:int.(forall y:int. +(((x>=0) and (y>0)) -> ((0<=computer_div(x,y)) and (computer_div(x,y)<=x))))) + +axiom computer_mod_bound : (forall x:int.(forall y:int. +((y<>0) -> (abs_int(computer_mod(x,y))<abs_int(y))))) + +axiom computer_mod_sign_pos : (forall x:int.(forall y:int. +(((x>=0) and (y<>0)) -> (computer_mod(x,y)>=0)))) + +axiom computer_mod_sign_neg : (forall x:int.(forall y:int. +(((x<=0) and (y<>0)) -> (computer_mod(x,y)<=0)))) + +axiom computer_rounds_toward_zero : (forall x:int.(forall y:int. +((y<>0) -> (abs_int((computer_div(x,y)y))<=abs_int(x))))) + +logic dummy : int -> prop + +logic assigns : int -> prop + +axiom positive_computer_div_div : (forall x:int.(forall y:int. +((x>0) -> ((y>0) -> (computer_div(x,y)=math_div(x,y)))))) + +type 'a set + +logic empty : 'a1 set + +logic singleton : 'a1 -> 'a1 set + +logic range : int,int -> int set + +logic union : 'a1 set,'a1 set -> 'a1 set + +logic inter : 'a1 set,'a1 set -> 'a1 set + +logic plus_int : int set,int set -> int set + +logic subset : 'a1 set,'a1 set -> prop + +logic range_inf : int -> int set + +logic range_sup : int -> int set + +logic integers_set : int set + +logic equiv : 'a1 set,'a1 set -> prop + +logic member : 'a1,'a1 set -> prop + +axiom singleton_def : (forall x:'a1.member(x, +singleton(x))) + +axiom singleton_eq : (forall x:'a1.(forall y:'a1.(member(x, +singleton(y)) <-> (x=y)))) + +axiom union_member : (forall x:'a1.(forall s1:'a1 set. +(forall s2:'a1 set[member(x,union(s1,s2))].(member(x, +union(s1,s2)) <-> (member(x,s1) or member(x, +s2)))))) + +axiom union_of_empty : (forall x:'a1 set[union(x,empty)]. +(union(x,empty)=x)) + +axiom inter_of_empty : (forall x:'a1 set[inter(x,empty)]. +(inter(x,empty)=empty)) + +axiom union_comm : (forall x:'a1 set.(forall y:'a1 set. +(union(x,y)=union(y,x)))) + +axiom inter_comm : (forall x:'a1 set.(forall y:'a1 set. +(inter(x,y)=inter(y,x)))) + +axiom inter_member : (forall x:'a1.(forall s1:'a1 set. +(forall s2:'a1 set[member(x,inter(s1,s2))].(member(x, +inter(s1,s2)) <-> (member(x,s1) and member(x, +s2)))))) + +axiom plus_int_member_1 : (forall sa:int set.(forall sb:int set. +(forall a:int.(forall b:int[member((a+b),plus_int(sa,sb))].(member(a, +sa) -> (member(b,sb) -> member((a+b), +plus_int(sa,sb)))))))) + +axiom plus_int_member_2 : (forall sa:int set.(forall sb:int set. +(forall c:int.(member(c,plus_int(sa,sb)) -> (exists a:int.(exists b:int. +(member(a,sa) and (member(b, +sb) and (c=(a+b)))))))))) + +axiom subset_empty : (forall sa:'a1 set.subset(empty, +sa)) + +axiom subset_sym : (forall sa:'a1 set.subset(sa, +sa)) + +axiom subset_trans : (forall sa:'a1 set.(forall sb:'a1 set. +(forall sc:'a1 set.(subset(sa,sb) -> (subset(sb,sc) -> subset(sa, +sc)))))) + +axiom subset_def : (forall sa:'a1 set.(forall sb:'a1 set[subset(sa,sb)]. +((forall a:'a1.(member(a,sa) -> member(a,sb))) <-> subset(sa, +sb)))) + +axiom range_def : (forall i:int.(forall j:int.(forall k:int. +(((i<=k) and (k<=j)) <-> member(k, +range(i,j)))))) + +axiom range_def1 : (forall i:int.(forall j:int.(forall k:int. +(((i<=k) and (k<=j)) -> member(k, +range(i,j)))))) + +axiom range_def2 : (forall i:int.(forall j:int.(forall k:int.(member(k, +range(i,j)) -> ((i<=k) and (k<=j)))))) + +axiom range_inf_def : (forall i:int.(forall k:int.((i<=k) <-> member(k, +range_inf(i))))) + +axiom range_sup_def : (forall j:int.(forall k:int.((k<=j) <-> member(k, +range_sup(j))))) + +axiom integers_set_def : (forall k:int.((k>=0) <-> member(k, +integers_set))) + +axiom equiv_def : (forall s1:'a1 set.(forall s2:'a1 set[equiv(s1,s2)]. +(((forall a:'a1.(member(a,s1) -> member(a,s2))) and (forall b:'a1.(member(b, +s2) -> member(b,s1)))) <-> equiv(s1, +s2)))) + +axiom equiv_refl : (forall s:'a1 set.equiv(s, +s)) + +axiom equiv_sym : (forall s1:'a1 set.(forall s2:'a1 set.(equiv(s1, +s2) -> equiv(s2, +s1)))) + +axiom equiv_trans : (forall s1:'a1 set.(forall s2:'a1 set.(forall s3:'a1 set. +(equiv(s1,s2) -> (equiv(s2,s3) -> equiv(s1, +s3)))))) + +logic as_uint8 : int -> int + +predicate is_uint8(x:int) = ((0<=x) and (x<256)) + +axiom as_uint8_def : (forall x:int. +is_uint8(as_uint8(x))) + +axiom as_uint8_involve : (forall x:int[as_uint8(as_uint8(x))]. +(as_uint8(as_uint8(x))=as_uint8(x))) + +axiom is_as_uint8 : (forall x:int[as_uint8(x)]. +(is_uint8(x) -> (as_uint8(x)=x))) + +logic as_sint8 : int -> int + +predicate is_sint8(x:int) = (((-128)<=x) and (x<128)) + +axiom as_sint8_def : (forall x:int. +is_sint8(as_sint8(x))) + +axiom as_sint8_involve : (forall x:int[as_sint8(as_sint8(x))]. +(as_sint8(as_sint8(x))=as_sint8(x))) + +axiom is_as_sint8 : (forall x:int[as_sint8(x)]. +(is_sint8(x) -> (as_sint8(x)=x))) + +logic as_uint16 : int -> int + +predicate is_uint16(x:int) = ((0<=x) and (x<65536)) + +axiom as_uint16_def : (forall x:int. +is_uint16(as_uint16(x))) + +axiom as_uint16_involve : (forall x:int[as_uint16(as_uint16(x))]. +(as_uint16(as_uint16(x))=as_uint16(x))) + +axiom is_as_uint16 : (forall x:int[as_uint16(x)]. +(is_uint16(x) -> (as_uint16(x)=x))) + +logic as_sint16 : int -> int + +predicate is_sint16(x:int) = (((-32768)<=x) and (x<32768)) + +axiom as_sint16_def : (forall x:int. +is_sint16(as_sint16(x))) + +axiom as_sint16_involve : (forall x:int[as_sint16(as_sint16(x))]. +(as_sint16(as_sint16(x))=as_sint16(x))) + +axiom is_as_sint16 : (forall x:int[as_sint16(x)]. +(is_sint16(x) -> (as_sint16(x)=x))) + +logic as_uint32 : int -> int + +predicate is_uint32(x:int) = ((0<=x) and (x<4294967296)) + +axiom as_uint32_def : (forall x:int. +is_uint32(as_uint32(x))) + +axiom as_uint32_involve : (forall x:int[as_uint32(as_uint32(x))]. +(as_uint32(as_uint32(x))=as_uint32(x))) + +axiom is_as_uint32 : (forall x:int[as_uint32(x)]. +(is_uint32(x) -> (as_uint32(x)=x))) + +logic as_sint32 : int -> int + +predicate is_sint32(x:int) = (((-2147483648)<=x) and (x<2147483648)) + +axiom as_sint32_def : (forall x:int. +is_sint32(as_sint32(x))) + +axiom as_sint32_involve : (forall x:int[as_sint32(as_sint32(x))]. +(as_sint32(as_sint32(x))=as_sint32(x))) + +axiom is_as_sint32 : (forall x:int[as_sint32(x)]. +(is_sint32(x) -> (as_sint32(x)=x))) + +logic as_uint64 : int -> int + +predicate is_uint64(x:int) = ((0<=x) and (x<18446744073709551616)) + +axiom as_uint64_def : (forall x:int. +is_uint64(as_uint64(x))) + +axiom as_uint64_involve : (forall x:int[as_uint64(as_uint64(x))]. +(as_uint64(as_uint64(x))=as_uint64(x))) + +axiom is_as_uint64 : (forall x:int[as_uint64(x)]. +(is_uint64(x) -> (as_uint64(x)=x))) + +logic as_sint64 : int -> int + +predicate is_sint64(x:int) = (((-9223372036854775808)<=x) and (x<9223372036854775808)) + +axiom as_sint64_def : (forall x:int. +is_sint64(as_sint64(x))) + +axiom as_sint64_involve : (forall x:int[as_sint64(as_sint64(x))]. +(as_sint64(as_sint64(x))=as_sint64(x))) + +axiom is_as_sint64 : (forall x:int[as_sint64(x)]. +(is_sint64(x) -> (as_sint64(x)=x))) + +logic as_float16 : real -> real + +logic is_float16 : real -> prop + +axiom as_float16_def : (forall x:real. +is_float16(as_float16(x))) + +axiom as_float16_involve : (forall x:real[as_float16(as_float16(x))]. +(as_float16(as_float16(x))=as_float16(x))) + +axiom is_as_float16 : (forall x:real[as_float16(x)]. +(is_float16(x) -> (as_float16(x)=x))) + +logic as_float32 : real -> real + +logic is_float32 : real -> prop + +axiom as_float32_def : (forall x:real. +is_float32(as_float32(x))) + +axiom as_float32_involve : (forall x:real[as_float32(as_float32(x))]. +(as_float32(as_float32(x))=as_float32(x))) + +axiom is_as_float32 : (forall x:real[as_float32(x)]. +(is_float32(x) -> (as_float32(x)=x))) + +logic as_float64 : real -> real + +logic is_float64 : real -> prop + +axiom as_float64_def : (forall x:real. +is_float64(as_float64(x))) + +axiom as_float64_involve : (forall x:real[as_float64(as_float64(x))]. +(as_float64(as_float64(x))=as_float64(x))) + +axiom is_as_float64 : (forall x:real[as_float64(x)]. +(is_float64(x) -> (as_float64(x)=x))) + +logic as_float128 : real -> real + +logic is_float128 : real -> prop + +axiom as_float128_def : (forall x:real. +is_float128(as_float128(x))) + +axiom as_float128_involve : (forall x:real[as_float128(as_float128(x))]. +(as_float128(as_float128(x))=as_float128(x))) + +axiom is_as_float128 : (forall x:real[as_float128(x)]. +(is_float128(x) -> (as_float128(x)=x))) + +type data + +logic data_of_uint8 : int -> data + +logic uint8_of_data : data -> int + +axiom is_uint8_of_data : (forall d:data[is_uint8(uint8_of_data(d))]. +is_uint8(uint8_of_data(d))) + +axiom uint8ofdata_dataofuint8 : (forall x:int[data_of_uint8(x)]. +(is_uint8(x) -> (uint8_of_data(data_of_uint8(x))=x))) + +logic data_of_sint8 : int -> data + +logic sint8_of_data : data -> int + +axiom is_sint8_of_data : (forall d:data[is_sint8(sint8_of_data(d))]. +is_sint8(sint8_of_data(d))) + +axiom sint8ofdata_dataofsint8 : (forall x:int[data_of_sint8(x)]. +(is_sint8(x) -> (sint8_of_data(data_of_sint8(x))=x))) + +logic data_of_uint16 : int -> data + +logic uint16_of_data : data -> int + +axiom is_uint16_of_data : (forall d:data[is_uint16(uint16_of_data(d))]. +is_uint16(uint16_of_data(d))) + +axiom uint16ofdata_dataofuint16 : (forall x:int[uint16_of_data(data_of_uint16(x))]. +(is_uint16(x) -> (uint16_of_data(data_of_uint16(x))=x))) + +logic data_of_sint16 : int -> data + +logic sint16_of_data : data -> int + +axiom is_sint16_of_data : (forall d:data[is_sint16(sint16_of_data(d))]. +is_sint16(sint16_of_data(d))) + +axiom sint16ofdata_dataofsint16 : (forall x:int[data_of_sint16(x)]. +(is_sint16(x) -> (sint16_of_data(data_of_sint16(x))=x))) + +logic data_of_uint32 : int -> data + +logic uint32_of_data : data -> int + +axiom is_uint32_of_data : (forall d:data[is_uint32(uint32_of_data(d))]. +is_uint32(uint32_of_data(d))) + +axiom uint32ofdata_dataofuint32 : (forall x:int[data_of_uint32(x)]. +(is_uint32(x) -> (uint32_of_data(data_of_uint32(x))=x))) + +logic data_of_sint32 : int -> data + +logic sint32_of_data : data -> int + +axiom is_sint32_of_data : (forall d:data[is_sint32(sint32_of_data(d))]. +is_sint32(sint32_of_data(d))) + +axiom sint32ofdata_dataofsint32 : (forall x:int[data_of_sint32(x)]. +(is_sint32(x) -> (sint32_of_data(data_of_sint32(x))=x))) + +logic data_of_uint64 : int -> data + +logic uint64_of_data : data -> int + +axiom is_uint64_of_data : (forall d:data[is_uint64(uint64_of_data(d))]. +is_uint64(uint64_of_data(d))) + +axiom uint64ofdata_dataofuint64 : (forall x:int[data_of_uint64(x)]. +(is_uint64(x) -> (uint64_of_data(data_of_uint64(x))=x))) + +logic data_of_sint64 : int -> data + +logic sint64_of_data : data -> int + +axiom is_sint64_of_data : (forall d:data[is_sint64(sint64_of_data(d))]. +is_sint64(sint64_of_data(d))) + +axiom sint64ofdata_dataofsint64 : (forall x:int[data_of_sint64(x)]. +(is_sint64(x) -> (sint64_of_data(data_of_sint64(x))=x))) + +logic data_of_float16 : real -> data + +logic float16_of_data : data -> real + +axiom is_float16_of_data : (forall d:data[is_float16(float16_of_data(d))]. +is_float16(float16_of_data(d))) + +axiom float16ofdata_dataoffloat16 : (forall x:real[data_of_float16(x)]. +(is_float16(x) -> (float16_of_data(data_of_float16(x))=x))) + +logic data_of_float32 : real -> data + +logic float32_of_data : data -> real + +axiom is_float32_of_data : (forall d:data[is_float32(float32_of_data(d))]. +is_float32(float32_of_data(d))) + +axiom float32ofdata_dataoffloat32 : (forall x:real[data_of_float32(x)]. +(is_float32(x) -> (float32_of_data(data_of_float32(x))=x))) + +logic data_of_float64 : real -> data + +logic float64_of_data : data -> real + +axiom is_float64_of_data : (forall d:data[is_float64(float64_of_data(d))]. +is_float64(float64_of_data(d))) + +axiom float64ofdata_dataoffloat64 : (forall x:real[data_of_float64(x)]. +(is_float64(x) -> (float64_of_data(data_of_float64(x))=x))) + +logic data_of_float128 : real -> data + +logic float128_of_data : data -> real + +axiom is_float128_of_data : (forall d:data[is_float128(float128_of_data(d))]. +is_float128(float128_of_data(d))) + +axiom float128ofdata_dataoffloat128 : (forall x:real[data_of_float128(x)]. +(is_float128(x) -> (float128_of_data(data_of_float128(x))=x))) + +logic set_range_index : 'a1 farray,int set,int -> 'a1 farray + +axiom set_range_def : (forall t:'a1 farray.(forall rg:int set.(forall k:int. +(forall i:int[set_range_index(t,rg,k)[i]].((not member(i, +rg)) -> (set_range_index(t,rg,k)[i]=t[i])))))) + +logic bnot : int -> int + +logic band : int,int -> int + +logic bor : int,int -> int + +logic bxor : int,int -> int + +logic lshift : int,int -> int + +logic rshift : int,int -> int + +logic int_not : int -> int + +logic int_and : int,int -> int + +logic int_or : int,int -> int + +logic int_xor : int,int -> int + +logic int_lsh : int,int -> int + +logic int_rshs : int,int -> int + +logic int_rshu : int,int -> int + +type pointer + +logic ptr : int,int -> pointer + +logic base : pointer -> int + +logic offset : pointer -> int + +axiom base_def : (forall b:int.(forall d:int[base(ptr(b,d))]. +(base(ptr(b,d))=b))) + +axiom offset_def : (forall b:int.(forall d:int[offset(ptr(b,d))]. +(offset(ptr(b,d))=d))) + +logic minus_ptr : pointer,pointer -> int + +axiom minus_ptr_def : (forall p1:pointer. +(forall p2:pointer[minus_ptr(p1,p2)]. +((base(p1)=base(p2)) -> (minus_ptr(p1,p2)=(offset(p1)-offset(p2)))))) + +predicate eq_ptr(a:pointer,b:pointer) = ((base(a)=base(b)) and (offset(a)=offset(b))) + +function eq_ptr_bool(a:pointer,b:pointer) : bool = bool_and(eq_int_bool(base(a),base(b)),eq_int_bool(offset(a),offset(b))) + +predicate lt_ptr(a:pointer,b:pointer) = ((base(a)=base(b)) and (offset(a)<offset(b))) + +function lt_ptr_bool(a:pointer,b:pointer) : bool = bool_and(eq_int_bool(base(a),base(b)),lt_int_bool(offset(a),offset(b))) + +predicate le_ptr(a:pointer,b:pointer) = ((base(a)=base(b)) and (offset(a)<=offset(b))) + +function le_ptr_bool(a:pointer,b:pointer) : bool = bool_and(eq_int_bool(base(a),base(b)),le_int_bool(offset(a),offset(b))) + +function shift(p:pointer,i:int) : pointer = ptr(base(p),(offset(p)+i)) + +axiom shift_0 : (forall p:pointer[shift(p,0)]. +(shift(p,0)=p)) + +axiom shift_shift : (forall p:pointer.(forall i:int. +(forall j:int[shift(shift(p,i),j)]. +(shift(shift(p,i),j)=shift(p,(i+j)))))) + +type trange + +logic range_ptr : int,int,int -> trange + +logic rbase : trange -> int + +logic roffset : trange -> int + +logic rsize : trange -> int + +axiom rbase_def : (forall b:int.(forall d:int. +(forall sz:int[rbase(range_ptr(b,d,sz))]. +(rbase(range_ptr(b,d,sz))=b)))) + +axiom roffset_def : (forall b:int.(forall d:int. +(forall sz:int[roffset(range_ptr(b,d,sz))]. +(roffset(range_ptr(b,d,sz))=d)))) + +axiom rsize_def : (forall b:int.(forall d:int. +(forall sz:int[rsize(range_ptr(b,d,sz))]. +(rsize(range_ptr(b,d,sz))=sz)))) + +function range_of_ptr(p:pointer,sz:int) : trange = range_ptr(base(p),offset(p),sz) + +axiom rbase_of_ptr : (forall p:pointer. +(forall sz:int[rbase(range_of_ptr(p,sz))]. +(rbase(range_of_ptr(p,sz))=base(p)))) + +axiom roffset_of_ptr : (forall p:pointer. +(forall sz:int[roffset(range_of_ptr(p,sz))]. +(roffset(range_of_ptr(p,sz))=offset(p)))) + +axiom rsize_of_ptr : (forall p:pointer. +(forall sz:int[rsize(range_of_ptr(p,sz))]. +(rsize(range_of_ptr(p,sz))=sz))) + +function range_of_ptr_range(p:pointer,d:int,sz:int) : trange = range_ptr(base(p),(offset(p)+d),sz) + +axiom rbase_of_ptr_range : (forall p:pointer.(forall d:int. +(forall sz:int[rbase(range_of_ptr_range(p,d,sz))]. +(rbase(range_of_ptr_range(p,d,sz))=base(p))))) + +axiom roffset_of_ptr_range : (forall p:pointer.(forall d:int. +(forall sz:int[roffset(range_of_ptr_range(p,d,sz))]. +(roffset(range_of_ptr_range(p,d,sz))=(offset(p)+d))))) + +axiom rsize_of_ptr_range : (forall p:pointer.(forall d:int. +(forall sz:int[rsize(range_of_ptr_range(p,d,sz))]. +(rsize(range_of_ptr_range(p,d,sz))=sz)))) + +predicate separated(r0:trange,r1:trange) = ((rbase(r0)=rbase(r1)) -> (((roffset(r0)+rsize(r0))<=roffset(r1)) or (roffset(r0)>=(roffset(r1)+rsize(r1))))) + +predicate valid(ta:int farray,r:trange) = ((rsize(r)>0) -> ((0<=roffset(r)) and ((roffset(r)+rsize(r))<=ta[rbase(r)]))) + +predicate included(r0:trange,r1:trange) = ((rbase(r0)=rbase(r1)) and ((roffset(r0)>=roffset(r1)) and ((roffset(r0)+rsize(r0))<=(roffset(r1)+rsize(r1))))) + +axiom valid_included : (forall r0:trange.(forall r1:trange. +(forall ta:int farray.(included(r0,r1) -> (valid(ta,r1) -> valid(ta, +r0)))))) + +logic global : int farray -> prop + + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/hoare_model.v frama-c-20111001+nitrogen+dfsg/src/wp/share/hoare_model.v --- frama-c-20110201+carbon+dfsg/src/wp/share/hoare_model.v 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/hoare_model.v 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,1332 @@ +(* This file was originally generated by why. + It can be modified; only the generated parts will be overwritten. ) +Require Import Reals. Require Import wp. + +(Why logic) Definition bool_and : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_or : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_xor : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_not : bool -> bool. +Admitted. + +(Why axiom) Lemma bool_and_def : + (forall (a:bool), + (forall (b:bool), ((bool_and a b) = true <-> a = true /\ b = true))). +Admitted. + +(Why axiom) Lemma bool_or_def : + (forall (a:bool), + (forall (b:bool), ((bool_or a b) = true <-> a = true \/ b = true))). +Admitted. + +(Why axiom) Lemma bool_xor_def : + (forall (a:bool), (forall (b:bool), ((bool_xor a b) = true <-> ~(a = b)))). +Admitted. + +(Why axiom) Lemma bool_not_def : + (forall (a:bool), ((bool_not a) = true <-> a = false)). +Admitted. + +(Why logic) Definition ite : forall (A1:Set), bool -> A1 -> A1 -> A1. +Admitted. +Implicit Arguments ite. + +(Why axiom) Lemma ite_true : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), (if_then_else true x y) = x)). +Admitted. + +(Why axiom) Lemma ite_false : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), (if_then_else false x y) = y)). +Admitted. + +(Why logic) Definition lt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition le_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition gt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition ge_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition eq_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition neq_int_bool : Z -> Z -> bool. +Admitted. + +(Why axiom) Lemma lt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((lt_int_bool x y) = true <-> x < y))). +Admitted. + +(Why axiom) Lemma le_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((le_int_bool x y) = true <-> x <= y))). +Admitted. + +(Why axiom) Lemma gt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((gt_int_bool x y) = true <-> x > y))). +Admitted. + +(Why axiom) Lemma ge_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((ge_int_bool x y) = true <-> x >= y))). +Admitted. + +(Why axiom) Lemma eq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((eq_int_bool x y) = true <-> x = y))). +Admitted. + +(Why axiom) Lemma neq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((neq_int_bool x y) = true <-> x <> y))). +Admitted. + +(Why logic) Definition abs_int : Z -> Z. +Admitted. + +(Why axiom) Lemma abs_int_pos : + (forall (x:Z), (x >= 0 -> (abs_int x) = x)). +Admitted. + +(Why axiom) Lemma abs_int_neg : + (forall (x:Z), (x <= 0 -> (abs_int x) = (Zopp x))). +Admitted. + +(Why logic) Definition int_max : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_min : Z -> Z -> Z. +Admitted. + +(Why axiom) Lemma int_max_is_ge : + (forall (x:Z), (forall (y:Z), (int_max x y) >= x /\ (int_max x y) >= y)). +Admitted. + +(Why axiom) Lemma int_max_is_some : + (forall (x:Z), (forall (y:Z), (int_max x y) = x \/ (int_max x y) = y)). +Admitted. + +(Why axiom) Lemma int_min_is_le : + (forall (x:Z), (forall (y:Z), (int_min x y) <= x /\ (int_min x y) <= y)). +Admitted. + +(Why axiom) Lemma int_min_is_some : + (forall (x:Z), (forall (y:Z), (int_min x y) = x \/ (int_min x y) = y)). +Admitted. + +(Why logic) Definition lt_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition le_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition gt_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition ge_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition eq_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition neq_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition add_real : R -> R -> R. +Admitted. + +(Why logic) Definition sub_real : R -> R -> R. +Admitted. + +(Why logic) Definition mul_real : R -> R -> R. +Admitted. + +(Why logic) Definition div_real : R -> R -> R. +Admitted. + +(Why logic) Definition neg_real : R -> R. +Admitted. + +(Why logic) Definition real_of_int : Z -> R. +Admitted. + +(Why axiom) Lemma real_of_int_zero : (eq (IZR 0) (0)%R). +Admitted. + +(Why axiom) Lemma real_of_int_one : (eq (IZR 1) (1)%R). +Admitted. + +(Why axiom) Lemma real_of_int_add : + (forall (x:Z), (forall (y:Z), (eq (IZR (x + y)) (Rplus (IZR x) (IZR y))))). +Admitted. + +(Why axiom) Lemma real_of_int_sub : + (forall (x:Z), (forall (y:Z), (eq (IZR (x - y)) (Rminus (IZR x) (IZR y))))). +Admitted. + +(Why logic) Definition truncate_real_to_int : R -> Z. +Admitted. + +(Why axiom) Lemma truncate_down_pos : + (forall (x:R), + ((Rge x (0)%R) -> (Rle (IZR (truncate_real_to_int x)) x) /\ + (Rlt x (IZR ((truncate_real_to_int x) + 1))))). +Admitted. + +(Why axiom) Lemma truncate_up_neg : + (forall (x:R), + ((Rle x (0)%R) -> (Rlt (IZR ((truncate_real_to_int x) - 1)) x) /\ + (Rle x (IZR (truncate_real_to_int x))))). +Admitted. + +(Why logic) Definition floor_real_to_int : R -> Z. +Admitted. + +(Why logic) Definition ceil_real_to_int : R -> Z. +Admitted. + +(Why logic) Definition lt_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition le_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition gt_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition ge_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition eq_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition neq_real_bool : R -> R -> bool. +Admitted. + +(Why axiom) Lemma lt_real_bool_axiom : + (forall (x:R), (forall (y:R), ((lt_real_bool x y) = true <-> (Rlt x y)))). +Admitted. + +(Why axiom) Lemma le_real_bool_axiom : + (forall (x:R), (forall (y:R), ((le_real_bool x y) = true <-> (Rle x y)))). +Admitted. + +(Why axiom) Lemma gt_real_bool_axiom : + (forall (x:R), (forall (y:R), ((gt_real_bool x y) = true <-> (Rgt x y)))). +Admitted. + +(Why axiom) Lemma ge_real_bool_axiom : + (forall (x:R), (forall (y:R), ((ge_real_bool x y) = true <-> (Rge x y)))). +Admitted. + +(Why axiom) Lemma eq_real_bool_axiom : + (forall (x:R), (forall (y:R), ((eq_real_bool x y) = true <-> (eq x y)))). +Admitted. + +(Why axiom) Lemma neq_real_bool_axiom : + (forall (x:R), (forall (y:R), ((neq_real_bool x y) = true <-> ~(eq x y)))). +Admitted. + +(Why logic) Definition real_max : R -> R -> R. +Admitted. + +(Why logic) Definition real_min : R -> R -> R. +Admitted. + +(Why axiom) Lemma real_max_is_ge : + (forall (x:R), + (forall (y:R), (Rge (real_max x y) x) /\ (Rge (real_max x y) y))). +Admitted. + +(Why axiom) Lemma real_max_is_some : + (forall (x:R), + (forall (y:R), (eq (real_max x y) x) \/ (eq (real_max x y) y))). +Admitted. + +(Why axiom) Lemma real_min_is_le : + (forall (x:R), + (forall (y:R), (Rle (real_min x y) x) /\ (Rle (real_min x y) y))). +Admitted. + +(Why axiom) Lemma real_min_is_some : + (forall (x:R), + (forall (y:R), (eq (real_min x y) x) \/ (eq (real_min x y) y))). +Admitted. + +(Why function) Definition sqr_real (x:R) := (Rmult x x). + +(Why logic) Definition sqrt_real : R -> R. +Admitted. + +(Why axiom) Lemma sqrt_pos : + (forall (x:R), ((Rge x (0)%R) -> (Rge (sqrt x) (0)%R))). +Admitted. + +(Why axiom) Lemma sqrt_sqr : + (forall (x:R), ((Rge x (0)%R) -> (eq (sqr_real (sqrt x)) x))). +Admitted. + +(Why axiom) Lemma sqr_sqrt : + (forall (x:R), ((Rge x (0)%R) -> (eq (sqrt (Rmult x x)) x))). +Admitted. + +(Why logic) Definition pow_real : R -> R -> R. +Admitted. + +(Why logic) Definition abs_real : R -> R. +Admitted. + +(Why axiom) Lemma abs_real_pos : + (forall (x:R), ((Rge x (0)%R) -> (eq (Rabs x) x))). +Admitted. + +(Why axiom) Lemma abs_real_neg : + (forall (x:R), ((Rle x (0)%R) -> (eq (Rabs x) (Ropp x)))). +Admitted. + +(Why logic) Definition exp : R -> R. +Admitted. + +(Why logic) Definition log : R -> R. +Admitted. + +(Why logic) Definition log10 : R -> R. +Admitted. + +(Why axiom) Lemma log_exp : (forall (x:R), (eq (log (exp x)) x)). +Admitted. + +(Why axiom) Lemma exp_log : + (forall (x:R), ((Rgt x (0)%R) -> (eq (exp (log x)) x))). +Admitted. + +(Why logic) Definition cos : R -> R. +Admitted. + +(Why logic) Definition sin : R -> R. +Admitted. + +(Why logic) Definition tan : R -> R. +Admitted. + +(Why logic) Definition pi : R. +Admitted. + +(Why logic) Definition cosh : R -> R. +Admitted. + +(Why logic) Definition sinh : R -> R. +Admitted. + +(Why logic) Definition tanh : R -> R. +Admitted. + +(Why logic) Definition acos : R -> R. +Admitted. + +(Why logic) Definition asin : R -> R. +Admitted. + +(Why logic) Definition atan : R -> R. +Admitted. + +(Why logic) Definition atan2 : R -> R -> R. +Admitted. + +(Why logic) Definition hypot : R -> R -> R. +Admitted. + +(Why axiom) Lemma prod_pos : + (forall (x:R), + (forall (y:R), + (((Rgt x (0)%R) /\ (Rgt y (0)%R) -> (Rgt (Rmult x y) (0)%R))) /\ + (((Rlt x (0)%R) /\ (Rlt y (0)%R) -> (Rgt (Rmult x y) (0)%R))))). +Admitted. + +(Why axiom) Lemma abs_minus : + (forall (x:R), (eq (Rabs (Ropp x)) (Rabs x))). +Admitted. + +(Why type) Definition farray: Set ->Set. +Admitted. + +(Why logic) Definition access : forall (A1:Set), (array A1) -> Z -> A1. +Admitted. +Implicit Arguments access. + +(Why logic) Definition update : + forall (A1:Set), (array A1) -> Z -> A1 -> (array A1). +Admitted. +Implicit Arguments update. + +(Why axiom) Lemma access_update : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), (forall (v:A1), (access (update a i v) i) = v))). +Admitted. + +(Why axiom) Lemma access_update_neq : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (j:Z), + (forall (v:A1), (i <> j -> (access (update a i v) j) = (access a j)))))). +Admitted. + +(Why logic) Definition array_length : forall (A1:Set), (array A1) -> Z. +Admitted. +Implicit Arguments array_length. + +(Why predicate) Definition sorted_array (t:(array Z)) (i:Z) (j:Z) + := (forall (k1:Z), + (forall (k2:Z), + ((i <= k1 /\ k1 <= k2) /\ k2 <= j -> (access t k1) <= (access t k2)))). + +(Why predicate) Definition exchange (A191:Set) (a1:(array A191)) (a2:(array A191)) (i:Z) (j:Z) + := (array_length a1) = (array_length a2) /\ + (access a1 i) = (access a2 j) /\ (access a2 i) = (access a1 j) /\ + (forall (k:Z), (k <> i /\ k <> j -> (access a1 k) = (access a2 k))). +Implicit Arguments exchange. + +(Why logic) Definition permut : + forall (A1:Set), (array A1) -> (array A1) -> Z -> Z -> Prop. +Admitted. +Implicit Arguments permut. + +(Why axiom) Lemma permut_refl : + forall (A1:Set), + (forall (t:(array A1)), (forall (l:Z), (forall (u:Z), (permut t t l u)))). +Admitted. + +(Why axiom) Lemma permut_sym : + forall (A1:Set), + (forall (t1:(array A1)), + (forall (t2:(array A1)), + (forall (l:Z), (forall (u:Z), ((permut t1 t2 l u) -> (permut t2 t1 l u)))))). +Admitted. + +(Why axiom) Lemma permut_trans : + forall (A1:Set), + (forall (t1:(array A1)), + (forall (t2:(array A1)), + (forall (t3:(array A1)), + (forall (l:Z), + (forall (u:Z), + ((permut t1 t2 l u) -> ((permut t2 t3 l u) -> (permut t1 t3 l u)))))))). +Admitted. + +(Why axiom) Lemma permut_exchange : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + (forall (i:Z), + (forall (j:Z), + (l <= i /\ i <= u -> + (l <= j /\ j <= u -> ((exchange a1 a2 i j) -> (permut a1 a2 l u)))))))))). +Admitted. + +(Why axiom) Lemma exchange_upd : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (j:Z), + (exchange a (update (update a i (access a j)) j (access a i)) i j)))). +Admitted. + +(Why axiom) Lemma permut_weakening : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l1:Z), + (forall (r1:Z), + (forall (l2:Z), + (forall (r2:Z), + ((l1 <= l2 /\ l2 <= r2) /\ r2 <= r1 -> + ((permut a1 a2 l2 r2) -> (permut a1 a2 l1 r1))))))))). +Admitted. + +(Why axiom) Lemma permut_eq : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + (l <= u -> + ((permut a1 a2 l u) -> + (forall (i:Z), (i < l \/ u (access a2 i) = (access a1 i))))))))). +Admitted. + +(Why predicate) Definition permutation (A200:Set) (a1:(array A200)) (a2:(array A200)) + := (permut a1 a2 0 ((array_length a1) - 1)). +Implicit Arguments permutation. + +(Why axiom) Lemma array_length_update : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (v:A1), (array_length (update a i v)) = (array_length a)))). +Admitted. + +(Why axiom) Lemma permut_array_length : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + ((permut a1 a2 l u) -> (array_length a1) = (array_length a2)))))). +Admitted. + +(Why logic) Definition computer_div : Z -> Z -> Z. +Admitted. + +(Why logic) Definition computer_mod : Z -> Z -> Z. +Admitted. + +(Why logic) Definition math_div : Z -> Z -> Z. +Admitted. + +(Why logic) Definition math_mod : Z -> Z -> Z. +Admitted. + +(Why axiom) Lemma math_div_mod : + (forall (x:Z), + (forall (y:Z), (y <> 0 -> x = (y (math_div x y) + (math_mod x y))))). +Admitted. + +(Why axiom) Lemma math_mod_bound : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> 0 <= (math_mod x y) /\ (math_mod x y) < (abs_int y)))). +Admitted. + +(Why axiom) Lemma computer_div_mod : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> x = (y * (computer_div x y) + (computer_mod x y))))). +Admitted. + +(Why axiom) Lemma computer_div_bound : + (forall (x:Z), + (forall (y:Z), + (x >= 0 /\ y > 0 -> 0 <= (computer_div x y) /\ (computer_div x y) <= x))). +Admitted. + +(Why axiom) Lemma computer_mod_bound : + (forall (x:Z), + (forall (y:Z), (y <> 0 -> (abs_int (computer_mod x y)) < (abs_int y)))). +Admitted. + +(Why axiom) Lemma computer_mod_sign_pos : + (forall (x:Z), + (forall (y:Z), (x >= 0 /\ y <> 0 -> (computer_mod x y) >= 0))). +Admitted. + +(Why axiom) Lemma computer_mod_sign_neg : + (forall (x:Z), + (forall (y:Z), (x <= 0 /\ y <> 0 -> (computer_mod x y) <= 0))). +Admitted. + +(Why axiom) Lemma computer_rounds_toward_zero : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> (abs_int ((computer_div x y) * y)) <= (abs_int x)))). +Admitted. + +(Why logic) Definition dummy : Z -> Prop. +Admitted. + +(Why logic) Definition assigns : Z -> Prop. +Admitted. + +(Why axiom) Lemma positive_computer_div_div : + (forall (x:Z), + (forall (y:Z), (x > 0 -> (y > 0 -> (computer_div x y) = (math_div x y))))). +Admitted. + +(Why type) Definition set: Set ->Set. +Admitted. + +(Why logic) Definition empty : forall (A1:Set), (set A1). +Admitted. +Set Contextual Implicit. +Implicit Arguments empty. +Unset Contextual Implicit. + +(Why logic) Definition singleton : forall (A1:Set), A1 -> (set A1). +Admitted. +Implicit Arguments singleton. + +(Why logic) Definition range : Z -> Z -> (set Z). +Admitted. + +(Why logic) Definition union : + forall (A1:Set), (set A1) -> (set A1) -> (set A1). +Admitted. +Implicit Arguments union. + +(Why logic) Definition inter : + forall (A1:Set), (set A1) -> (set A1) -> (set A1). +Admitted. +Implicit Arguments inter. + +(Why logic) Definition plus_int : (set Z) -> (set Z) -> (set Z). +Admitted. + +(Why logic) Definition subset : + forall (A1:Set), (set A1) -> (set A1) -> Prop. +Admitted. +Implicit Arguments subset. + +(Why logic) Definition range_inf : Z -> (set Z). +Admitted. + +(Why logic) Definition range_sup : Z -> (set Z). +Admitted. + +(Why logic) Definition integers_set : (set Z). +Admitted. + +(Why logic) Definition equiv : + forall (A1:Set), (set A1) -> (set A1) -> Prop. +Admitted. +Implicit Arguments equiv. + +(Why logic) Definition member : forall (A1:Set), A1 -> (set A1) -> Prop. +Admitted. +Implicit Arguments member. + +(Why axiom) Lemma singleton_def : + forall (A1:Set), (forall (x:A1), (member x (singleton x))). +Admitted. + +(Why axiom) Lemma singleton_eq : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), ((member x (singleton y)) <-> x = y))). +Admitted. + +(Why axiom) Lemma union_member : + forall (A1:Set), + (forall (x:A1), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((member x (union s1 s2)) <-> (member x s1) \/ (member x s2))))). +Admitted. + +(Why axiom) Lemma union_of_empty : + forall (A1:Set), (forall (x:(set A1)), (union x (@empty A1)) = x). +Admitted. + +(Why axiom) Lemma inter_of_empty : + forall (A1:Set), (forall (x:(set A1)), (inter x (@empty A1)) = (@empty A1)). +Admitted. + +(Why axiom) Lemma union_comm : + forall (A1:Set), + (forall (x:(set A1)), (forall (y:(set A1)), (union x y) = (union y x))). +Admitted. + +(Why axiom) Lemma inter_comm : + forall (A1:Set), + (forall (x:(set A1)), (forall (y:(set A1)), (inter x y) = (inter y x))). +Admitted. + +(Why axiom) Lemma inter_member : + forall (A1:Set), + (forall (x:A1), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((member x (inter s1 s2)) <-> (member x s1) /\ (member x s2))))). +Admitted. + +(Why axiom) Lemma plus_int_member_1 : + (forall (sa:(set Z)), + (forall (sb:(set Z)), + (forall (a:Z), + (forall (b:Z), + ((member a sa) -> ((member b sb) -> (member (a + b) (plus_int sa sb)))))))). +Admitted. + +(Why axiom) Lemma plus_int_member_2 : + (forall (sa:(set Z)), + (forall (sb:(set Z)), + (forall (c:Z), + ((member c (plus_int sa sb)) -> + (exists a:Z, + (exists b:Z, (member a sa) /\ (member b sb) /\ c = (a + b))))))). +Admitted. + +(Why axiom) Lemma subset_empty : + forall (A1:Set), (forall (sa:(set A1)), (subset (@empty A1) sa)). +Admitted. + +(Why axiom) Lemma subset_sym : + forall (A1:Set), (forall (sa:(set A1)), (subset sa sa)). +Admitted. + +(Why axiom) Lemma subset_trans : + forall (A1:Set), + (forall (sa:(set A1)), + (forall (sb:(set A1)), + (forall (sc:(set A1)), + ((subset sa sb) -> ((subset sb sc) -> (subset sa sc)))))). +Admitted. + +(Why axiom) Lemma subset_def : + forall (A1:Set), + (forall (sa:(set A1)), + (forall (sb:(set A1)), + ((forall (a:A1), ((member a sa) -> (member a sb))) <-> (subset sa sb)))). +Admitted. + +(Why axiom) Lemma range_def : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), (i <= k /\ k <= j <-> (member k (range i j)))))). +Admitted. + +(Why axiom) Lemma range_def1 : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), (i <= k /\ k <= j -> (member k (range i j)))))). +Admitted. + +(Why axiom) Lemma range_def2 : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), ((member k (range i j)) -> i <= k /\ k <= j)))). +Admitted. + +(Why axiom) Lemma range_inf_def : + (forall (i:Z), (forall (k:Z), (i <= k <-> (member k (range_inf i))))). +Admitted. + +(Why axiom) Lemma range_sup_def : + (forall (j:Z), (forall (k:Z), (k <= j <-> (member k (range_sup j))))). +Admitted. + +(Why axiom) Lemma integers_set_def : + (forall (k:Z), (k >= 0 <-> (member k integers_set))). +Admitted. + +(Why axiom) Lemma equiv_def : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((forall (a:A1), ((member a s1) -> (member a s2))) /\ + (forall (b:A1), ((member b s2) -> (member b s1))) <-> (equiv s1 s2)))). +Admitted. + +(Why axiom) Lemma equiv_refl : + forall (A1:Set), (forall (s:(set A1)), (equiv s s)). +Admitted. + +(Why axiom) Lemma equiv_sym : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), ((equiv s1 s2) -> (equiv s2 s1)))). +Admitted. + +(Why axiom) Lemma equiv_trans : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + (forall (s3:(set A1)), + ((equiv s1 s2) -> ((equiv s2 s3) -> (equiv s1 s3)))))). +Admitted. + +(Why logic) Definition as_uint8 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint8 (x:Z) := 0 <= x /\ x < 256. + +(Why axiom) Lemma as_uint8_def : (forall (x:Z), (is_uint8 (as_uint8 x))). +Admitted. + +(Why axiom) Lemma as_uint8_involve : + (forall (x:Z), (as_uint8 (as_uint8 x)) = (as_uint8 x)). +Admitted. + +(Why axiom) Lemma is_as_uint8 : + (forall (x:Z), ((is_uint8 x) -> (as_uint8 x) = x)). +Admitted. + +(Why logic) Definition as_sint8 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint8 (x:Z) := (-128) <= x /\ x < 128. + +(Why axiom) Lemma as_sint8_def : (forall (x:Z), (is_sint8 (as_sint8 x))). +Admitted. + +(Why axiom) Lemma as_sint8_involve : + (forall (x:Z), (as_sint8 (as_sint8 x)) = (as_sint8 x)). +Admitted. + +(Why axiom) Lemma is_as_sint8 : + (forall (x:Z), ((is_sint8 x) -> (as_sint8 x) = x)). +Admitted. + +(Why logic) Definition as_uint16 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint16 (x:Z) := 0 <= x /\ x < 65536. + +(Why axiom) Lemma as_uint16_def : + (forall (x:Z), (is_uint16 (as_uint16 x))). +Admitted. + +(Why axiom) Lemma as_uint16_involve : + (forall (x:Z), (as_uint16 (as_uint16 x)) = (as_uint16 x)). +Admitted. + +(Why axiom) Lemma is_as_uint16 : + (forall (x:Z), ((is_uint16 x) -> (as_uint16 x) = x)). +Admitted. + +(Why logic) Definition as_sint16 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint16 (x:Z) := (-32768) <= x /\ x < 32768. + +(Why axiom) Lemma as_sint16_def : + (forall (x:Z), (is_sint16 (as_sint16 x))). +Admitted. + +(Why axiom) Lemma as_sint16_involve : + (forall (x:Z), (as_sint16 (as_sint16 x)) = (as_sint16 x)). +Admitted. + +(Why axiom) Lemma is_as_sint16 : + (forall (x:Z), ((is_sint16 x) -> (as_sint16 x) = x)). +Admitted. + +(Why logic) Definition as_uint32 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint32 (x:Z) := 0 <= x /\ x < 4294967296. + +(Why axiom) Lemma as_uint32_def : + (forall (x:Z), (is_uint32 (as_uint32 x))). +Admitted. + +(Why axiom) Lemma as_uint32_involve : + (forall (x:Z), (as_uint32 (as_uint32 x)) = (as_uint32 x)). +Admitted. + +(Why axiom) Lemma is_as_uint32 : + (forall (x:Z), ((is_uint32 x) -> (as_uint32 x) = x)). +Admitted. + +(Why logic) Definition as_sint32 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint32 (x:Z) + := (-2147483648) <= x /\ x < 2147483648. + +(Why axiom) Lemma as_sint32_def : + (forall (x:Z), (is_sint32 (as_sint32 x))). +Admitted. + +(Why axiom) Lemma as_sint32_involve : + (forall (x:Z), (as_sint32 (as_sint32 x)) = (as_sint32 x)). +Admitted. + +(Why axiom) Lemma is_as_sint32 : + (forall (x:Z), ((is_sint32 x) -> (as_sint32 x) = x)). +Admitted. + +(Why logic) Definition as_uint64 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint64 (x:Z) + := 0 <= x /\ x < 18446744073709551616. + +(Why axiom) Lemma as_uint64_def : + (forall (x:Z), (is_uint64 (as_uint64 x))). +Admitted. + +(Why axiom) Lemma as_uint64_involve : + (forall (x:Z), (as_uint64 (as_uint64 x)) = (as_uint64 x)). +Admitted. + +(Why axiom) Lemma is_as_uint64 : + (forall (x:Z), ((is_uint64 x) -> (as_uint64 x) = x)). +Admitted. + +(Why logic) Definition as_sint64 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint64 (x:Z) + := (-9223372036854775808) <= x /\ x < 9223372036854775808. + +(Why axiom) Lemma as_sint64_def : + (forall (x:Z), (is_sint64 (as_sint64 x))). +Admitted. + +(Why axiom) Lemma as_sint64_involve : + (forall (x:Z), (as_sint64 (as_sint64 x)) = (as_sint64 x)). +Admitted. + +(Why axiom) Lemma is_as_sint64 : + (forall (x:Z), ((is_sint64 x) -> (as_sint64 x) = x)). +Admitted. + +(Why logic) Definition as_float16 : R -> R. +Admitted. + +(Why logic) Definition is_float16 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float16_def : + (forall (x:R), (is_float16 (as_float16 x))). +Admitted. + +(Why axiom) Lemma as_float16_involve : + (forall (x:R), (eq (as_float16 (as_float16 x)) (as_float16 x))). +Admitted. + +(Why axiom) Lemma is_as_float16 : + (forall (x:R), ((is_float16 x) -> (eq (as_float16 x) x))). +Admitted. + +(Why logic) Definition as_float32 : R -> R. +Admitted. + +(Why logic) Definition is_float32 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float32_def : + (forall (x:R), (is_float32 (as_float32 x))). +Admitted. + +(Why axiom) Lemma as_float32_involve : + (forall (x:R), (eq (as_float32 (as_float32 x)) (as_float32 x))). +Admitted. + +(Why axiom) Lemma is_as_float32 : + (forall (x:R), ((is_float32 x) -> (eq (as_float32 x) x))). +Admitted. + +(Why logic) Definition as_float64 : R -> R. +Admitted. + +(Why logic) Definition is_float64 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float64_def : + (forall (x:R), (is_float64 (as_float64 x))). +Admitted. + +(Why axiom) Lemma as_float64_involve : + (forall (x:R), (eq (as_float64 (as_float64 x)) (as_float64 x))). +Admitted. + +(Why axiom) Lemma is_as_float64 : + (forall (x:R), ((is_float64 x) -> (eq (as_float64 x) x))). +Admitted. + +(Why logic) Definition as_float128 : R -> R. +Admitted. + +(Why logic) Definition is_float128 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float128_def : + (forall (x:R), (is_float128 (as_float128 x))). +Admitted. + +(Why axiom) Lemma as_float128_involve : + (forall (x:R), (eq (as_float128 (as_float128 x)) (as_float128 x))). +Admitted. + +(Why axiom) Lemma is_as_float128 : + (forall (x:R), ((is_float128 x) -> (eq (as_float128 x) x))). +Admitted. + +(Why type) Definition data: Set. +Admitted. + +(Why logic) Definition data_of_uint8 : Z -> data. +Admitted. + +(Why logic) Definition uint8_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint8_of_data : + (forall (d:data), (is_uint8 (uint8_of_data d))). +Admitted. + +(Why axiom) Lemma uint8ofdata_dataofuint8 : + (forall (x:Z), ((is_uint8 x) -> (uint8_of_data (data_of_uint8 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint8 : Z -> data. +Admitted. + +(Why logic) Definition sint8_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint8_of_data : + (forall (d:data), (is_sint8 (sint8_of_data d))). +Admitted. + +(Why axiom) Lemma sint8ofdata_dataofsint8 : + (forall (x:Z), ((is_sint8 x) -> (sint8_of_data (data_of_sint8 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint16 : Z -> data. +Admitted. + +(Why logic) Definition uint16_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint16_of_data : + (forall (d:data), (is_uint16 (uint16_of_data d))). +Admitted. + +(Why axiom) Lemma uint16ofdata_dataofuint16 : + (forall (x:Z), ((is_uint16 x) -> (uint16_of_data (data_of_uint16 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint16 : Z -> data. +Admitted. + +(Why logic) Definition sint16_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint16_of_data : + (forall (d:data), (is_sint16 (sint16_of_data d))). +Admitted. + +(Why axiom) Lemma sint16ofdata_dataofsint16 : + (forall (x:Z), ((is_sint16 x) -> (sint16_of_data (data_of_sint16 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint32 : Z -> data. +Admitted. + +(Why logic) Definition uint32_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint32_of_data : + (forall (d:data), (is_uint32 (uint32_of_data d))). +Admitted. + +(Why axiom) Lemma uint32ofdata_dataofuint32 : + (forall (x:Z), ((is_uint32 x) -> (uint32_of_data (data_of_uint32 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint32 : Z -> data. +Admitted. + +(Why logic) Definition sint32_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint32_of_data : + (forall (d:data), (is_sint32 (sint32_of_data d))). +Admitted. + +(Why axiom) Lemma sint32ofdata_dataofsint32 : + (forall (x:Z), ((is_sint32 x) -> (sint32_of_data (data_of_sint32 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint64 : Z -> data. +Admitted. + +(Why logic) Definition uint64_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint64_of_data : + (forall (d:data), (is_uint64 (uint64_of_data d))). +Admitted. + +(Why axiom) Lemma uint64ofdata_dataofuint64 : + (forall (x:Z), ((is_uint64 x) -> (uint64_of_data (data_of_uint64 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint64 : Z -> data. +Admitted. + +(Why logic) Definition sint64_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint64_of_data : + (forall (d:data), (is_sint64 (sint64_of_data d))). +Admitted. + +(Why axiom) Lemma sint64ofdata_dataofsint64 : + (forall (x:Z), ((is_sint64 x) -> (sint64_of_data (data_of_sint64 x)) = x)). +Admitted. + +(Why logic) Definition data_of_float16 : R -> data. +Admitted. + +(Why logic) Definition float16_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float16_of_data : + (forall (d:data), (is_float16 (float16_of_data d))). +Admitted. + +(Why axiom) Lemma float16ofdata_dataoffloat16 : + (forall (x:R), + ((is_float16 x) -> (eq (float16_of_data (data_of_float16 x)) x))). +Admitted. + +(Why logic) Definition data_of_float32 : R -> data. +Admitted. + +(Why logic) Definition float32_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float32_of_data : + (forall (d:data), (is_float32 (float32_of_data d))). +Admitted. + +(Why axiom) Lemma float32ofdata_dataoffloat32 : + (forall (x:R), + ((is_float32 x) -> (eq (float32_of_data (data_of_float32 x)) x))). +Admitted. + +(Why logic) Definition data_of_float64 : R -> data. +Admitted. + +(Why logic) Definition float64_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float64_of_data : + (forall (d:data), (is_float64 (float64_of_data d))). +Admitted. + +(Why axiom) Lemma float64ofdata_dataoffloat64 : + (forall (x:R), + ((is_float64 x) -> (eq (float64_of_data (data_of_float64 x)) x))). +Admitted. + +(Why logic) Definition data_of_float128 : R -> data. +Admitted. + +(Why logic) Definition float128_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float128_of_data : + (forall (d:data), (is_float128 (float128_of_data d))). +Admitted. + +(Why axiom) Lemma float128ofdata_dataoffloat128 : + (forall (x:R), + ((is_float128 x) -> (eq (float128_of_data (data_of_float128 x)) x))). +Admitted. + +(Why logic) Definition set_range_index : + forall (A1:Set), (array A1) -> (set Z) -> Z -> (array A1). +Admitted. +Implicit Arguments set_range_index. + +(Why axiom) Lemma set_range_def : + forall (A1:Set), + (forall (t:(array A1)), + (forall (rg:(set Z)), + (forall (k:Z), + (forall (i:Z), + (~(member i rg) -> (access (set_range_index t rg k) i) = (access t i)))))). +Admitted. + +(Why logic) Definition bnot : Z -> Z. +Admitted. + +(Why logic) Definition band : Z -> Z -> Z. +Admitted. + +(Why logic) Definition bor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition bxor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition lshift : Z -> Z -> Z. +Admitted. + +(Why logic) Definition rshift : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_not : Z -> Z. +Admitted. + +(Why logic) Definition int_and : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_or : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_xor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_lsh : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_rshs : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_rshu : Z -> Z -> Z. +Admitted. + +(Why type) Definition pointer: Set. +Admitted. + +(Why logic) Definition ptr : Z -> Z -> pointer. +Admitted. + +(Why logic) Definition base : pointer -> Z. +Admitted. + +(Why logic) Definition offset : pointer -> Z. +Admitted. + +(Why axiom) Lemma base_def : + (forall (b:Z), (forall (d:Z), (base (ptr b d)) = b)). +Admitted. + +(Why axiom) Lemma offset_def : + (forall (b:Z), (forall (d:Z), (offset (ptr b d)) = d)). +Admitted. + +(Why logic) Definition minus_ptr : pointer -> pointer -> Z. +Admitted. + +(Why axiom) Lemma minus_ptr_def : + (forall (p1:pointer), + (forall (p2:pointer), + ((base p1) = (base p2) -> (minus_ptr p1 p2) = ((offset p1) - (offset p2))))). +Admitted. + +(Why predicate) Definition eq_ptr (a:pointer) (b:pointer) + := (base a) = (base b) /\ (offset a) = (offset b). + +(Why function) Definition eq_ptr_bool (a:pointer) (b:pointer) + := (bool_and + (eq_int_bool (base a) (base b)) (eq_int_bool (offset a) (offset b))). + +(Why predicate) Definition lt_ptr (a:pointer) (b:pointer) + := (base a) = (base b) /\ (offset a) < (offset b). + +(Why function) Definition lt_ptr_bool (a:pointer) (b:pointer) + := (bool_and + (eq_int_bool (base a) (base b)) (lt_int_bool (offset a) (offset b))). + +(Why predicate) Definition le_ptr (a:pointer) (b:pointer) + := (base a) = (base b) /\ (offset a) <= (offset b). + +(Why function) Definition le_ptr_bool (a:pointer) (b:pointer) + := (bool_and + (eq_int_bool (base a) (base b)) (le_int_bool (offset a) (offset b))). + +(Why function) Definition shift (p:pointer) (i:Z) + := (ptr (base p) ((offset p) + i)). + +(Why axiom) Lemma shift_0 : (forall (p:pointer), (shift p 0) = p). +Admitted. + +(Why axiom) Lemma shift_shift : + (forall (p:pointer), + (forall (i:Z), (forall (j:Z), (shift (shift p i) j) = (shift p (i + j))))). +Admitted. + +(Why type) Definition trange: Set. +Admitted. + +(Why logic) Definition range_ptr : Z -> Z -> Z -> trange. +Admitted. + +(Why logic) Definition rbase : trange -> Z. +Admitted. + +(Why logic) Definition roffset : trange -> Z. +Admitted. + +(Why logic) Definition rsize : trange -> Z. +Admitted. + +(Why axiom) Lemma rbase_def : + (forall (b:Z), + (forall (d:Z), (forall (sz:Z), (rbase (range_ptr b d sz)) = b))). +Admitted. + +(Why axiom) Lemma roffset_def : + (forall (b:Z), + (forall (d:Z), (forall (sz:Z), (roffset (range_ptr b d sz)) = d))). +Admitted. + +(Why axiom) Lemma rsize_def : + (forall (b:Z), + (forall (d:Z), (forall (sz:Z), (rsize (range_ptr b d sz)) = sz))). +Admitted. + +(Why function) Definition range_of_ptr (p:pointer) (sz:Z) + := (range_ptr (base p) (offset p) sz). + +(Why axiom) Lemma rbase_of_ptr : + (forall (p:pointer), + (forall (sz:Z), (rbase (range_of_ptr p sz)) = (base p))). +Admitted. + +(Why axiom) Lemma roffset_of_ptr : + (forall (p:pointer), + (forall (sz:Z), (roffset (range_of_ptr p sz)) = (offset p))). +Admitted. + +(Why axiom) Lemma rsize_of_ptr : + (forall (p:pointer), (forall (sz:Z), (rsize (range_of_ptr p sz)) = sz)). +Admitted. + +(Why function) Definition range_of_ptr_range (p:pointer) (d:Z) (sz:Z) + := (range_ptr (base p) ((offset p) + d) sz). + +(Why axiom) Lemma rbase_of_ptr_range : + (forall (p:pointer), + (forall (d:Z), + (forall (sz:Z), (rbase (range_of_ptr_range p d sz)) = (base p)))). +Admitted. + +(Why axiom) Lemma roffset_of_ptr_range : + (forall (p:pointer), + (forall (d:Z), + (forall (sz:Z), (roffset (range_of_ptr_range p d sz)) = ((offset p) + d)))). +Admitted. + +(Why axiom) Lemma rsize_of_ptr_range : + (forall (p:pointer), + (forall (d:Z), (forall (sz:Z), (rsize (range_of_ptr_range p d sz)) = sz))). +Admitted. + +(Why predicate) Definition separated (r0:trange) (r1:trange) + := ((rbase r0) = (rbase r1) -> ((roffset r0) + (rsize r0)) <= + (roffset r1) \/ (roffset r0) >= ((roffset r1) + (rsize r1))). + +(Why predicate) Definition valid (ta:(array Z)) (r:trange) + := ((rsize r) > 0 -> 0 <= (roffset r) /\ ((roffset r) + (rsize r)) <= + (access ta (rbase r))). + +(Why predicate) Definition included (r0:trange) (r1:trange) + := (rbase r0) = (rbase r1) /\ (roffset r0) >= (roffset r1) /\ + ((roffset r0) + (rsize r0)) <= ((roffset r1) + (rsize r1)). + +(Why axiom) Lemma valid_included : + (forall (r0:trange), + (forall (r1:trange), + (forall (ta:(array Z)), + ((included r0 r1) -> ((valid ta r1) -> (valid ta r0)))))). +Admitted. + +(Why logic) Definition global : (array Z) -> Prop. +Admitted. + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/hoare_model.why frama-c-20111001+nitrogen+dfsg/src/wp/share/hoare_model.why --- frama-c-20110201+carbon+dfsg/src/wp/share/hoare_model.why 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/hoare_model.why 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,562 @@ +(* --- Headers for WHY --- ) + +include "bool.why" +include "integer.why" +include "real.why" +include "arrays.why" +include "divisions.why" +( -------------------------------------------------------------------------- ) +( --- ACSL Definitions --- ) +( -------------------------------------------------------------------------- ) + +logic dummy : int -> prop +logic assigns : int -> prop + + +( -------------------------------------------------------------------------- ) +( --- Divisions enhanced specification --- ) +( -------------------------------------------------------------------------- *) + +axiom positive_computer_div_div: + forall x,y:int. + x >0 -> y >0 -> computer_div(x,y) = math_div(x,y) + + +(************************************************************************) +(* Specification of Set as First Class Value *) +(************************************************************************) +(* From Figure 2.6 in ACSL:ANSI/ISO C Specification Language ) + +type 'a set + +logic empty : 'a set +logic singleton : 'a -> 'a set +logic range : int,int -> int set +logic union : 'a set , 'a set -> 'a set +logic inter : 'a set , 'a set -> 'a set +logic plus_int : int set, int set -> int set +logic subset : 'a set,'a set -> prop +logic range_inf: int -> int set +logic range_sup:int->int set +logic integers_set : int set +logic equiv : 'a set ,'a set -> prop +logic member : 'a,'a set -> prop + +axiom singleton_def : + forall x:'a. member (x, singleton(x)) + +axiom singleton_eq: + forall x,y:'a. member(x,singleton(y)) <-> x=y + +axiom union_member : + forall x:'a. forall s1,s2:'a set [member(x, union(s1,s2))]. + member(x, union(s1,s2)) <-> member(x,s1) or member(x,s2) + +axiom union_of_empty : + forall x:'a set [union(x,empty)]. union(x,empty) = x + +axiom inter_of_empty : + forall x:'a set [inter(x,empty)]. inter(x,empty) = empty + +axiom union_comm : + forall x,y:'a set. union(x,y) = union(y,x) + +axiom inter_comm : + forall x,y:'a set. inter(x,y) = inter(y,x) + +axiom inter_member : + forall x:'a. forall s1,s2:'a set [member(x,inter(s1,s2))]. + member(x,inter(s1,s2)) <-> member(x,s1) and member(x,s2) + +axiom plus_int_member_1: + forall sa,sb:int set. + forall a,b:int [member((a+b), plus_int(sa,sb))]. + member(a,sa) -> member(b,sb) -> + member((a+b), plus_int(sa,sb)) + +axiom plus_int_member_2: + forall sa,sb:int set. + forall c:int. + member(c,plus_int(sa,sb)) -> + exists a:int. exists b:int. + member(a,sa) and member(b,sb) and c=a+b + +axiom subset_empty : + forall sa:'a set. subset(empty,sa) + +axiom subset_sym: + forall sa:'a set. subset(sa,sa) + +axiom subset_trans : + forall sa,sb,sc: 'a set. + subset(sa,sb) -> + subset(sb,sc) -> + subset(sa,sc) + +axiom subset_def: + forall sa,sb:'a set [subset(sa,sb)]. + (forall a:'a. member(a,sa) -> member(a,sb)) <-> subset(sa,sb) + + +axiom range_def: + forall i,j,k:int. i <= k<= j <-> member (k,range(i,j)) + +axiom range_def1: + forall i,j,k:int. i <= k<= j -> member (k,range(i,j)) + +axiom range_def2: + forall i,j,k:int.member (k,range(i,j)) -> i <= k<= j + +axiom range_inf_def: ( range_inf(i) is [ i .. ] ) + forall i,k: int. i <= k <-> member (k,range_inf(i)) + +axiom range_sup_def: ( range_sup(j) is [ .. j ] *) + forall j,k: int. k <= j <-> member (k,range_sup(j)) + +axiom integers_set_def: + forall k:int. k >= 0 <-> member(k,integers_set) + +axiom equiv_def: + forall s1,s2:'a set [equiv(s1,s2)]. ( + (forall a:'a. member(a,s1) -> member(a,s2)) and + (forall b:'a. member(b,s2) -> member(b,s1))) <-> + equiv(s1,s2) + +axiom equiv_refl: + forall s:'a set. equiv(s,s) + +axiom equiv_sym: + forall s1,s2:'a set. equiv(s1,s2) -> equiv(s2,s1) + +axiom equiv_trans: + forall s1,s2,s3:'a set. + equiv(s1,s2) -> equiv(s2,s3) -> equiv(s1,s3) + + + +(************************************************************************) +(* Integers and Reals ) +() + + +logic as_uint8 :int -> int +predicate is_uint8(x:int) = 0 <= x < 256 +axiom as_uint8_def : forall x:int. is_uint8(as_uint8(x)) +axiom as_uint8_involve : + forall x:int [as_uint8(as_uint8(x))]. as_uint8(as_uint8(x)) = as_uint8(x) +axiom is_as_uint8: forall x:int [as_uint8(x)]. is_uint8(x) -> as_uint8(x) = x + +logic as_sint8 :int -> int +predicate is_sint8(x:int) = -128 <= x < 128 +axiom as_sint8_def : forall x:int. is_sint8(as_sint8(x)) +axiom as_sint8_involve : + forall x:int [as_sint8(as_sint8(x))]. as_sint8(as_sint8(x)) = as_sint8(x) +axiom is_as_sint8: forall x:int[as_sint8(x)]. is_sint8(x) -> as_sint8(x) = x + + +logic as_uint16 :int -> int +predicate is_uint16(x:int) = 0 <= x < 65536 +axiom as_uint16_def : forall x:int. is_uint16(as_uint16(x)) +axiom as_uint16_involve : + forall x:int [as_uint16(as_uint16(x))]. + as_uint16(as_uint16(x)) = as_uint16(x) +axiom is_as_uint16: forall x:int [as_uint16(x)]. is_uint16(x) -> as_uint16(x) = x + +logic as_sint16 :int -> int +predicate is_sint16(x:int) = -32768 <= x < 32768 +axiom as_sint16_def : forall x:int. is_sint16(as_sint16(x)) +axiom as_sint16_involve : + forall x:int [as_sint16(as_sint16(x))]. + as_sint16(as_sint16(x)) = as_sint16(x) +axiom is_as_sint16: forall x:int [as_sint16(x)]. is_sint16(x) -> as_sint16(x) = x + + +logic as_uint32 :int -> int +predicate is_uint32(x:int) = 0 <= x < 4294967296 +axiom as_uint32_def : forall x:int. is_uint32(as_uint32(x)) +axiom as_uint32_involve : + forall x:int [as_uint32(as_uint32(x))]. + as_uint32(as_uint32(x)) = as_uint32(x) +axiom is_as_uint32: forall x:int [as_uint32(x)]. is_uint32(x) -> as_uint32(x) = x + +logic as_sint32 :int -> int +predicate is_sint32(x:int) = -2147483648 <= x < 2147483648 +axiom as_sint32_def : forall x:int. is_sint32(as_sint32(x)) +axiom as_sint32_involve : + forall x:int [as_sint32(as_sint32(x))]. + as_sint32(as_sint32(x)) = as_sint32(x) +axiom is_as_sint32: forall x:int [as_sint32(x)]. is_sint32(x) -> as_sint32(x) = x + + +logic as_uint64 :int -> int +predicate is_uint64(x:int) = 0 <= x < 18446744073709551616 +axiom as_uint64_def : forall x:int. is_uint64(as_uint64(x)) +axiom as_uint64_involve : + forall x:int [as_uint64(as_uint64(x))]. + as_uint64(as_uint64(x)) = as_uint64(x) +axiom is_as_uint64: forall x:int [as_uint64(x)]. is_uint64(x) -> as_uint64(x) = x + +logic as_sint64 :int -> int +predicate is_sint64(x:int) = -9223372036854775808 <= x < 9223372036854775808 +axiom as_sint64_def : forall x:int. is_sint64(as_sint64(x)) +axiom as_sint64_involve : + forall x:int [as_sint64(as_sint64(x))]. + as_sint64(as_sint64(x)) = as_sint64(x) +axiom is_as_sint64: forall x:int [as_sint64(x)]. is_sint64(x) -> as_sint64(x) = x + + +logic as_float16 :real -> real +logic is_float16 :real -> prop +axiom as_float16_def : forall x:real. is_float16(as_float16(x)) +axiom as_float16_involve : + forall x:real [as_float16(as_float16(x))]. + as_float16(as_float16(x)) = as_float16(x) +axiom is_as_float16: forall x:real [as_float16(x)]. is_float16(x) -> as_float16(x) = x + + +logic as_float32 :real -> real +logic is_float32 :real -> prop +axiom as_float32_def : forall x:real. is_float32(as_float32(x)) +axiom as_float32_involve : + forall x:real [as_float32(as_float32(x))]. + as_float32(as_float32(x)) = as_float32(x) +axiom is_as_float32: + forall x:real [as_float32(x)]. is_float32(x) -> as_float32(x) = x + + +logic as_float64 :real -> real +logic is_float64 :real -> prop +axiom as_float64_def : + forall x:real. is_float64(as_float64(x)) +axiom as_float64_involve : + forall x:real [as_float64(as_float64(x))]. + as_float64(as_float64(x)) = as_float64(x) +axiom is_as_float64: + forall x:real [as_float64(x)]. is_float64(x) -> as_float64(x) = x + + +logic as_float128 :real -> real +logic is_float128 :real -> prop +axiom as_float128_def : + forall x:real. is_float128(as_float128(x)) +axiom as_float128_involve : + forall x:real [as_float128(as_float128(x))]. + as_float128(as_float128(x)) = as_float128(x) +axiom is_as_float128: + forall x:real [as_float128(x)]. is_float128(x) -> as_float128(x) = x + +() +( Memory Data Type ) +() + +type data + +logic data_of_uint8: int -> data +logic uint8_of_data: data -> int + +axiom is_uint8_of_data: + forall d:data [is_uint8(uint8_of_data(d))].is_uint8(uint8_of_data(d)) + +axiom uint8ofdata_dataofuint8: + forall x:int [data_of_uint8(x)]. + is_uint8(x) -> uint8_of_data(data_of_uint8(x)) = x + +logic data_of_sint8: int -> data +logic sint8_of_data: data -> int + +axiom is_sint8_of_data: + forall d:data [is_sint8(sint8_of_data(d))]. is_sint8(sint8_of_data(d)) + +axiom sint8ofdata_dataofsint8: + forall x:int [data_of_sint8(x)]. + is_sint8(x) -> sint8_of_data(data_of_sint8(x)) = x + +logic data_of_uint16: int -> data +logic uint16_of_data: data -> int + +axiom is_uint16_of_data: + forall d:data [is_uint16(uint16_of_data(d))]. is_uint16(uint16_of_data(d)) + +axiom uint16ofdata_dataofuint16: + forall x:int [uint16_of_data(data_of_uint16(x))]. + is_uint16(x) -> uint16_of_data(data_of_uint16(x)) = x + +logic data_of_sint16: int -> data +logic sint16_of_data: data -> int + +axiom is_sint16_of_data: + forall d:data [is_sint16(sint16_of_data(d))]. is_sint16(sint16_of_data(d)) + +axiom sint16ofdata_dataofsint16: + forall x:int [data_of_sint16(x)]. + is_sint16(x) -> sint16_of_data(data_of_sint16(x)) = x + +logic data_of_uint32: int -> data +logic uint32_of_data: data -> int + +axiom is_uint32_of_data: + forall d:data [is_uint32(uint32_of_data(d))]. is_uint32(uint32_of_data(d)) + +axiom uint32ofdata_dataofuint32: + forall x:int [data_of_uint32(x)]. + is_uint32(x) -> uint32_of_data(data_of_uint32(x)) = x + +logic data_of_sint32: int -> data +logic sint32_of_data: data -> int + +axiom is_sint32_of_data: + forall d:data [is_sint32(sint32_of_data(d))]. is_sint32(sint32_of_data(d)) + +axiom sint32ofdata_dataofsint32: + forall x:int [data_of_sint32(x)]. + is_sint32(x) -> sint32_of_data(data_of_sint32(x)) = x + +logic data_of_uint64: int -> data +logic uint64_of_data: data -> int + +axiom is_uint64_of_data: + forall d:data [is_uint64(uint64_of_data(d))]. is_uint64(uint64_of_data(d)) + +axiom uint64ofdata_dataofuint64: + forall x:int [data_of_uint64(x)]. + is_uint64(x) -> uint64_of_data(data_of_uint64(x)) = x + +logic data_of_sint64: int -> data +logic sint64_of_data: data -> int + +axiom is_sint64_of_data: + forall d:data [is_sint64(sint64_of_data(d))]. is_sint64(sint64_of_data(d)) + +axiom sint64ofdata_dataofsint64: + forall x:int [data_of_sint64(x)]. + is_sint64(x) -> sint64_of_data(data_of_sint64(x)) = x + +logic data_of_float16: real -> data +logic float16_of_data: data -> real + +axiom is_float16_of_data: + forall d:data [is_float16(float16_of_data(d))]. is_float16(float16_of_data(d)) +axiom float16ofdata_dataoffloat16: + forall x:real [data_of_float16(x)]. + is_float16(x) -> float16_of_data(data_of_float16(x)) = x + +logic data_of_float32: real -> data +logic float32_of_data: data -> real + +axiom is_float32_of_data: + forall d:data [is_float32(float32_of_data(d))]. is_float32(float32_of_data(d)) +axiom float32ofdata_dataoffloat32: + forall x:real [data_of_float32(x)]. + is_float32(x) -> float32_of_data(data_of_float32(x)) = x + +logic data_of_float64: real -> data +logic float64_of_data: data -> real + +axiom is_float64_of_data: + forall d:data [is_float64(float64_of_data(d))]. is_float64(float64_of_data(d)) +axiom float64ofdata_dataoffloat64: + forall x:real [data_of_float64(x)]. + is_float64(x) -> float64_of_data(data_of_float64(x)) = x + +logic data_of_float128: real -> data +logic float128_of_data: data -> real + +axiom is_float128_of_data: + forall d:data [is_float128(float128_of_data(d))]. is_float128(float128_of_data(d)) +axiom float128ofdata_dataoffloat128: + forall x:real [data_of_float128(x)]. + is_float128(x) -> float128_of_data(data_of_float128(x)) = x + + +() +( Update of Arrays over a set of Index *) +(************************************************************************) + + +logic set_range_index: + 'a farray (* array), int set ( set of index), int (uniq key*) -> 'a farray + +axiom set_range_def : + forall t: 'a farray. + forall rg: int set. + forall k:int. + forall i:int [access(set_range_index(t,rg,k),i)]. + not (member(i,rg)) -> + access(set_range_index(t,rg,k),i) = access(t,i) + +(************************************************************************) +(* Bitwise Operations *) +() + +logic bnot: int -> int +logic band: int,int -> int +logic bor: int,int -> int +logic bxor: int,int -> int +logic lshift: int,int -> int +logic rshift: int,int -> int + +logic int_not: int -> int +logic int_and: int,int -> int +logic int_or: int,int -> int +logic int_xor: int,int -> int +logic int_lsh: int,int -> int +logic int_rshs: int,int -> int +logic int_rshu: int,int -> int +(**) +(* ) +( This file is part of Frama-C. ) +( ) +( Copyright (C) 2007-2010 ) +( CEA (Commissariat � l'�nergie atomique et aux �nergies ) +( alternatives) ) +( INRIA (Institut National de Recherche en Informatique et en ) +( Automatique) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version v2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(TODO : waiting for pair theory in alt-ergo to use them here ! ) + +type pointer + +logic ptr: int(base), int(offset) -> pointer +logic base : pointer -> int +logic offset : pointer -> int + +axiom base_def: + forall b,d:int [base(ptr(b,d))]. base(ptr(b,d)) = b + +axiom offset_def: + forall b,d:int [offset(ptr(b,d))]. offset(ptr(b,d)) = d + + +logic minus_ptr: pointer,pointer -> int + +axiom minus_ptr_def: + forall p1,p2:pointer [minus_ptr(p1,p2)]. + base(p1) =base(p2) -> + minus_ptr(p1,p2) = offset(p1) - offset(p2) + +predicate eq_ptr (a:pointer, b:pointer) = + base(a) = base(b) and offset(a) = offset(b) + +function eq_ptr_bool (a:pointer, b:pointer): bool = + bool_and (eq_int_bool(base(a), base(b)), + eq_int_bool(offset(a),offset(b))) + + +predicate lt_ptr (a:pointer, b:pointer) = + base(a) = base(b) and + offset(a) < offset(b) + +function lt_ptr_bool (a:pointer, b:pointer): bool = + bool_and (eq_int_bool(base(a), base(b)), + lt_int_bool(offset(a),offset(b))) + + +predicate le_ptr (a:pointer, b:pointer) = + base(a) = base(b) and + offset(a) <= offset(b) + +function le_ptr_bool (a:pointer, b:pointer): bool = + bool_and (eq_int_bool(base(a), base(b)), + le_int_bool(offset(a),offset(b))) + + +function shift (p:pointer, i:int): pointer = + ptr(base(p),offset(p)+i) + +axiom shift_0: + forall p:pointer [shift(p,0)]. shift(p,0) = p + +axiom shift_shift: + forall p:pointer. forall i,j:int [shift(shift(p,i),j)]. + shift(shift(p,i),j) = shift(p,i+j) + + + +type trange + +logic range_ptr : int(base) , int (offset), int (size) -> trange + +logic rbase : trange -> int +logic roffset : trange -> int +logic rsize : trange -> int + +axiom rbase_def : + forall b,d,sz:int [rbase(range_ptr(b,d,sz))]. + rbase(range_ptr(b,d,sz)) = b + +axiom roffset_def : + forall b,d,sz:int [roffset(range_ptr(b,d,sz))]. + roffset(range_ptr(b,d,sz)) = d + +axiom rsize_def : + forall b,d,sz:int [rsize(range_ptr(b,d,sz))]. + rsize(range_ptr(b,d,sz)) = sz + +function range_of_ptr (p:pointer,sz:int) :trange = + range_ptr(base(p),offset(p),sz) + +axiom rbase_of_ptr : + forall p:pointer. forall sz:int [rbase(range_of_ptr(p,sz))]. + rbase(range_of_ptr(p,sz)) = base(p) + +axiom roffset_of_ptr : + forall p:pointer. forall sz:int [roffset(range_of_ptr(p,sz))]. + roffset(range_of_ptr(p,sz)) = offset(p) + +axiom rsize_of_ptr : + forall p:pointer. forall sz:int [rsize(range_of_ptr(p,sz))]. + rsize(range_of_ptr(p,sz)) = sz + +function range_of_ptr_range (p:pointer,d:int,sz:int) : trange = + range_ptr(base(p),offset(p)+d,sz) + +axiom rbase_of_ptr_range : + forall p:pointer. forall d,sz:int [rbase(range_of_ptr_range(p,d,sz))]. + rbase(range_of_ptr_range(p,d,sz)) = base(p) + +axiom roffset_of_ptr_range : + forall p:pointer. forall d,sz:int [roffset(range_of_ptr_range(p,d,sz))]. + roffset(range_of_ptr_range(p,d,sz)) = offset(p)+d + +axiom rsize_of_ptr_range : + forall p:pointer. forall d,sz:int [rsize(range_of_ptr_range(p,d,sz))]. + rsize(range_of_ptr_range(p,d,sz)) = sz + + +predicate separated (r0:trange, r1:trange) = + rbase(r0) = rbase(r1) -> + roffset(r0)+ rsize(r0) <= roffset(r1) or + roffset(r0) >= roffset(r1) + rsize(r1) + + +predicate valid (ta:int farray, r : trange) = + rsize(r) > 0 -> + ( 0 <= roffset(r) and roffset(r) + rsize(r) <= access(ta,rbase(r))) + +predicate included(r0:trange, r1:trange) = + rbase(r0) = rbase(r1) and + roffset(r0) >= roffset(r1) and + roffset(r0) + rsize(r0) <= roffset(r1) + rsize(r1) + +axiom valid_included : + forall r0,r1:trange. + forall ta: int farray. + included(r0,r1) -> valid(ta,r1) -> valid(ta,r0) + +logic global : int farray -> prop + + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/runtime_ergo.why frama-c-20111001+nitrogen+dfsg/src/wp/share/runtime_ergo.why --- frama-c-20110201+carbon+dfsg/src/wp/share/runtime_ergo.why 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/runtime_ergo.why 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,1514 @@ +logic eq_unit : unit,unit -> prop + +logic neq_unit : unit,unit -> prop + +logic eq_bool : bool,bool -> prop + +logic neq_bool : bool,bool -> prop + +logic lt_int : int,int -> prop + +logic le_int : int,int -> prop + +logic gt_int : int,int -> prop + +logic ge_int : int,int -> prop + +logic eq_int : int,int -> prop + +logic neq_int : int,int -> prop + +logic add_int : int,int -> int + +logic sub_int : int,int -> int + +logic mul_int : int,int -> int + +logic neg_int : int -> int + +predicate zwf_zero(a:int,b:int) = ((0<=b) and (a<b)) + +logic bool_and : bool,bool -> bool + +logic bool_or : bool,bool -> bool + +logic bool_xor : bool,bool -> bool + +logic bool_not : bool -> bool + +axiom bool_and_def : (forall a:bool.(forall b:bool. +((bool_and(a,b)=true) <-> ((a=true) and (b=true))))) + +axiom bool_or_def : (forall a:bool.(forall b:bool. +((bool_or(a,b)=true) <-> ((a=true) or (b=true))))) + +axiom bool_xor_def : (forall a:bool.(forall b:bool. +((bool_xor(a,b)=true) <-> (a<>b)))) + +axiom bool_not_def : (forall a:bool. +((bool_not(a)=true) <-> (a=false))) + +logic ite : bool,'a1,'a1 -> 'a1 + +axiom ite_true : (forall x:'a1.(forall y:'a1. +(ite(true,x,y)=x))) + +axiom ite_false : (forall x:'a1.(forall y:'a1. +(ite(false,x,y)=y))) + +logic lt_int_bool : int,int -> bool + +logic le_int_bool : int,int -> bool + +logic gt_int_bool : int,int -> bool + +logic ge_int_bool : int,int -> bool + +logic eq_int_bool : int,int -> bool + +logic neq_int_bool : int,int -> bool + +axiom lt_int_bool_axiom : (forall x:int.(forall y:int. +((lt_int_bool(x,y)=true) <-> (x<y)))) + +axiom le_int_bool_axiom : (forall x:int.(forall y:int. +((le_int_bool(x,y)=true) <-> (x<=y)))) + +axiom gt_int_bool_axiom : (forall x:int.(forall y:int. +((gt_int_bool(x,y)=true) <-> (x>y)))) + +axiom ge_int_bool_axiom : (forall x:int.(forall y:int. +((ge_int_bool(x,y)=true) <-> (x>=y)))) + +axiom eq_int_bool_axiom : (forall x:int.(forall y:int. +((eq_int_bool(x,y)=true) <-> (x=y)))) + +axiom neq_int_bool_axiom : (forall x:int.(forall y:int. +((neq_int_bool(x,y)=true) <-> (x<>y)))) + +logic abs_int : int -> int + +axiom abs_int_pos : (forall x:int. +((x>=0) -> (abs_int(x)=x))) + +axiom abs_int_neg : (forall x:int. +((x<=0) -> (abs_int(x)=(-x)))) + +logic int_max : int,int -> int + +logic int_min : int,int -> int + +axiom int_max_is_ge : (forall x:int.(forall y:int. +((int_max(x,y)>=x) and (int_max(x,y)>=y)))) + +axiom int_max_is_some : (forall x:int.(forall y:int. +((int_max(x,y)=x) or (int_max(x,y)=y)))) + +axiom int_min_is_le : (forall x:int.(forall y:int. +((int_min(x,y)<=x) and (int_min(x,y)<=y)))) + +axiom int_min_is_some : (forall x:int.(forall y:int. +((int_min(x,y)=x) or (int_min(x,y)=y)))) + +logic lt_real : real,real -> prop + +logic le_real : real,real -> prop + +logic gt_real : real,real -> prop + +logic ge_real : real,real -> prop + +logic eq_real : real,real -> prop + +logic neq_real : real,real -> prop + +logic add_real : real,real -> real + +logic sub_real : real,real -> real + +logic mul_real : real,real -> real + +logic div_real : real,real -> real + +logic neg_real : real -> real + +logic real_of_int : int -> real + +axiom real_of_int_zero : (real_of_int(0)=0.0) + +axiom real_of_int_one : (real_of_int(1)=1.0) + +axiom real_of_int_add : (forall x:int.(forall y:int. +(real_of_int((x+y))=(real_of_int(x)+real_of_int(y))))) + +axiom real_of_int_sub : (forall x:int.(forall y:int. +(real_of_int((x-y))=(real_of_int(x)-real_of_int(y))))) + +logic truncate_real_to_int : real -> int + +axiom truncate_down_pos : (forall x:real. +((x>=0.0) -> ((real_of_int(truncate_real_to_int(x))<=x) and (x<real_of_int((truncate_real_to_int(x)+1)))))) + +axiom truncate_up_neg : (forall x:real. +((x<=0.0) -> ((real_of_int((truncate_real_to_int(x)-1))<x) and (x<=real_of_int(truncate_real_to_int(x)))))) + +logic floor_real_to_int : real -> int + +logic ceil_real_to_int : real -> int + +logic lt_real_bool : real,real -> bool + +logic le_real_bool : real,real -> bool + +logic gt_real_bool : real,real -> bool + +logic ge_real_bool : real,real -> bool + +logic eq_real_bool : real,real -> bool + +logic neq_real_bool : real,real -> bool + +axiom lt_real_bool_axiom : (forall x:real.(forall y:real. +((lt_real_bool(x,y)=true) <-> (x<y)))) + +axiom le_real_bool_axiom : (forall x:real.(forall y:real. +((le_real_bool(x,y)=true) <-> (x<=y)))) + +axiom gt_real_bool_axiom : (forall x:real.(forall y:real. +((gt_real_bool(x,y)=true) <-> (x>y)))) + +axiom ge_real_bool_axiom : (forall x:real.(forall y:real. +((ge_real_bool(x,y)=true) <-> (x>=y)))) + +axiom eq_real_bool_axiom : (forall x:real.(forall y:real. +((eq_real_bool(x,y)=true) <-> (x=y)))) + +axiom neq_real_bool_axiom : (forall x:real.(forall y:real. +((neq_real_bool(x,y)=true) <-> (x<>y)))) + +logic real_max : real,real -> real + +logic real_min : real,real -> real + +axiom real_max_is_ge : (forall x:real.(forall y:real. +((real_max(x,y)>=x) and (real_max(x,y)>=y)))) + +axiom real_max_is_some : (forall x:real.(forall y:real. +((real_max(x,y)=x) or (real_max(x,y)=y)))) + +axiom real_min_is_le : (forall x:real.(forall y:real. +((real_min(x,y)<=x) and (real_min(x,y)<=y)))) + +axiom real_min_is_some : (forall x:real.(forall y:real. +((real_min(x,y)=x) or (real_min(x,y)=y)))) + +function sqr_real(x:real) : real = (xx) + +logic sqrt_real : real -> real + +axiom sqrt_pos : (forall x:real. +((x>=0.0) -> (sqrt_real(x)>=0.0))) + +axiom sqrt_sqr : (forall x:real. +((x>=0.0) -> (sqr_real(sqrt_real(x))=x))) + +axiom sqr_sqrt : (forall x:real. +((x>=0.0) -> (sqrt_real((xx))=x))) + +logic pow_real : real,real -> real + +logic abs_real : real -> real + +axiom abs_real_pos : (forall x:real[abs_real(x)]. +((x>=0.0) -> (abs_real(x)=x))) + +axiom abs_real_neg : (forall x:real[abs_real(x)]. +((x<=0.0) -> (abs_real(x)=(-x)))) + +logic exp : real -> real + +logic log : real -> real + +logic log10 : real -> real + +axiom log_exp : (forall x:real. +(log(exp(x))=x)) + +axiom exp_log : (forall x:real. +((x>0.0) -> (exp(log(x))=x))) + +logic cos : real -> real + +logic sin : real -> real + +logic tan : real -> real + +logic pi : real + +logic cosh : real -> real + +logic sinh : real -> real + +logic tanh : real -> real + +logic acos : real -> real + +logic asin : real -> real + +logic atan : real -> real + +logic atan2 : real,real -> real + +logic hypot : real,real -> real + +axiom prod_pos : (forall x:real.(forall y:real. +((((x>0.0) and (y>0.0)) -> ((xy)>0.0)) and (((x<0.0) and (y<0.0)) -> ((xy)>0.0))))) + +axiom abs_minus : (forall x:real. +(abs_real((-x))=abs_real(x))) + + +logic access : 'a1 farray,int -> 'a1 + +logic update : 'a1 farray,int,'a1 -> 'a1 farray + +axiom access_update : (forall a:'a1 farray.(forall i:int.(forall v:'a1. +(a[i<-v][i]=v)))) + +axiom access_update_neq : (forall a:'a1 farray.(forall i:int.(forall j:int. +(forall v:'a1. +((i<>j) -> (a[i<-v][j]=a[j])))))) + +logic array_length : 'a1 farray -> int + +predicate sorted_array(t:int farray,i:int,j:int) = (forall k1:int. +(forall k2:int. +((((i<=k1) and (k1<=k2)) and (k2<=j)) -> (t[k1]<=t[k2])))) + +predicate exchange(a1:'a1 farray,a2:'a1 farray,i:int,j:int) = ((array_length(a1)=array_length(a2)) and ((a1[i]=a2[j]) and ((a2[i]=a1[j]) and ( +forall k:int. +(((k<>i) and (k<>j)) -> (a1[k]=a2[k])))))) + +logic permut : 'a1 farray,'a1 farray,int,int -> prop + +axiom permut_refl : (forall t:'a1 farray.(forall l:int.(forall u:int. +permut(t,t,l, +u)))) + +axiom permut_sym : (forall t1:'a1 farray.(forall t2:'a1 farray.(forall l:int. +(forall u:int.(permut(t1,t2,l,u) -> permut(t2,t1,l, +u)))))) + +axiom permut_trans : (forall t1:'a1 farray.(forall t2:'a1 farray. +(forall t3:'a1 farray.(forall l:int.(forall u:int.(permut(t1,t2,l, +u) -> (permut(t2,t3,l,u) -> permut(t1,t3,l, +u)))))))) + +axiom permut_exchange : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l:int.(forall u:int.(forall i:int.(forall j:int. +(((l<=i) and (i<=u)) -> (((l<=j) and (j<=u)) -> (exchange(a1,a2,i, +j) -> permut(a1,a2,l, +u)))))))))) + +axiom exchange_upd : (forall a:'a1 farray.(forall i:int.(forall j:int. +exchange(a,a[i<-a[j]][j<-a[i]],i, +j)))) + +axiom permut_weakening : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l1:int.(forall r1:int.(forall l2:int.(forall r2:int. +((((l1<=l2) and (l2<=r2)) and (r2<=r1)) -> (permut(a1,a2,l2,r2) -> permut(a1, +a2,l1, +r1))))))))) + +axiom permut_eq : (forall a1:'a1 farray.(forall a2:'a1 farray.(forall l:int. +(forall u:int.((l<=u) -> (permut(a1,a2,l,u) -> (forall i:int. +(((i<l) or (u<i)) -> (a2[i]=a1[i]))))))))) + +predicate permutation(a1:'a1 farray,a2:'a1 farray) = permut(a1,a2,0, +(array_length(a1)-1)) + +axiom array_length_update : (forall a:'a1 farray.(forall i:int.(forall v:'a1. +(array_length(a[i<-v])=array_length(a))))) + +axiom permut_array_length : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l:int.(forall u:int.(permut(a1,a2,l, +u) -> (array_length(a1)=array_length(a2))))))) + +logic computer_div : int,int -> int + +logic computer_mod : int,int -> int + +logic math_div : int,int -> int + +logic math_mod : int,int -> int + +axiom math_div_mod : (forall x:int.(forall y:int. +((y<>0) -> (x=((ymath_div(x,y))+math_mod(x,y)))))) + +axiom math_mod_bound : (forall x:int.(forall y:int. +((y<>0) -> ((0<=math_mod(x,y)) and (math_mod(x,y)<abs_int(y)))))) + +axiom computer_div_mod : (forall x:int. +(forall y:int[computer_div(x,y),computer_mod(x,y)]. +((y<>0) -> (x=((ycomputer_div(x,y))+computer_mod(x,y)))))) + +axiom computer_div_bound : (forall x:int.(forall y:int. +(((x>=0) and (y>0)) -> ((0<=computer_div(x,y)) and (computer_div(x,y)<=x))))) + +axiom computer_mod_bound : (forall x:int.(forall y:int. +((y<>0) -> (abs_int(computer_mod(x,y))<abs_int(y))))) + +axiom computer_mod_sign_pos : (forall x:int.(forall y:int. +(((x>=0) and (y<>0)) -> (computer_mod(x,y)>=0)))) + +axiom computer_mod_sign_neg : (forall x:int.(forall y:int. +(((x<=0) and (y<>0)) -> (computer_mod(x,y)<=0)))) + +axiom computer_rounds_toward_zero : (forall x:int.(forall y:int. +((y<>0) -> (abs_int((computer_div(x,y)y))<=abs_int(x))))) + +logic dummy : int -> prop + +logic assigns : int -> prop + +axiom positive_computer_div_div : (forall x:int.(forall y:int. +((x>0) -> ((y>0) -> (computer_div(x,y)=math_div(x,y)))))) + +type 'a set + +logic empty : 'a1 set + +logic singleton : 'a1 -> 'a1 set + +logic range : int,int -> int set + +logic union : 'a1 set,'a1 set -> 'a1 set + +logic inter : 'a1 set,'a1 set -> 'a1 set + +logic plus_int : int set,int set -> int set + +logic subset : 'a1 set,'a1 set -> prop + +logic range_inf : int -> int set + +logic range_sup : int -> int set + +logic integers_set : int set + +logic equiv : 'a1 set,'a1 set -> prop + +logic member : 'a1,'a1 set -> prop + +axiom singleton_def : (forall x:'a1.member(x, +singleton(x))) + +axiom singleton_eq : (forall x:'a1.(forall y:'a1.(member(x, +singleton(y)) <-> (x=y)))) + +axiom union_member : (forall x:'a1.(forall s1:'a1 set. +(forall s2:'a1 set[member(x,union(s1,s2))].(member(x, +union(s1,s2)) <-> (member(x,s1) or member(x, +s2)))))) + +axiom union_of_empty : (forall x:'a1 set[union(x,empty)]. +(union(x,empty)=x)) + +axiom inter_of_empty : (forall x:'a1 set[inter(x,empty)]. +(inter(x,empty)=empty)) + +axiom union_comm : (forall x:'a1 set.(forall y:'a1 set. +(union(x,y)=union(y,x)))) + +axiom inter_comm : (forall x:'a1 set.(forall y:'a1 set. +(inter(x,y)=inter(y,x)))) + +axiom inter_member : (forall x:'a1.(forall s1:'a1 set. +(forall s2:'a1 set[member(x,inter(s1,s2))].(member(x, +inter(s1,s2)) <-> (member(x,s1) and member(x, +s2)))))) + +axiom plus_int_member_1 : (forall sa:int set.(forall sb:int set. +(forall a:int.(forall b:int[member((a+b),plus_int(sa,sb))].(member(a, +sa) -> (member(b,sb) -> member((a+b), +plus_int(sa,sb)))))))) + +axiom plus_int_member_2 : (forall sa:int set.(forall sb:int set. +(forall c:int.(member(c,plus_int(sa,sb)) -> (exists a:int.(exists b:int. +(member(a,sa) and (member(b, +sb) and (c=(a+b)))))))))) + +axiom subset_empty : (forall sa:'a1 set.subset(empty, +sa)) + +axiom subset_sym : (forall sa:'a1 set.subset(sa, +sa)) + +axiom subset_trans : (forall sa:'a1 set.(forall sb:'a1 set. +(forall sc:'a1 set.(subset(sa,sb) -> (subset(sb,sc) -> subset(sa, +sc)))))) + +axiom subset_def : (forall sa:'a1 set.(forall sb:'a1 set[subset(sa,sb)]. +((forall a:'a1.(member(a,sa) -> member(a,sb))) <-> subset(sa, +sb)))) + +axiom range_def : (forall i:int.(forall j:int.(forall k:int. +(((i<=k) and (k<=j)) <-> member(k, +range(i,j)))))) + +axiom range_def1 : (forall i:int.(forall j:int.(forall k:int. +(((i<=k) and (k<=j)) -> member(k, +range(i,j)))))) + +axiom range_def2 : (forall i:int.(forall j:int.(forall k:int.(member(k, +range(i,j)) -> ((i<=k) and (k<=j)))))) + +axiom range_inf_def : (forall i:int.(forall k:int.((i<=k) <-> member(k, +range_inf(i))))) + +axiom range_sup_def : (forall j:int.(forall k:int.((k<=j) <-> member(k, +range_sup(j))))) + +axiom integers_set_def : (forall k:int.((k>=0) <-> member(k, +integers_set))) + +axiom equiv_def : (forall s1:'a1 set.(forall s2:'a1 set[equiv(s1,s2)]. +(((forall a:'a1.(member(a,s1) -> member(a,s2))) and (forall b:'a1.(member(b, +s2) -> member(b,s1)))) <-> equiv(s1, +s2)))) + +axiom equiv_refl : (forall s:'a1 set.equiv(s, +s)) + +axiom equiv_sym : (forall s1:'a1 set.(forall s2:'a1 set.(equiv(s1, +s2) -> equiv(s2, +s1)))) + +axiom equiv_trans : (forall s1:'a1 set.(forall s2:'a1 set.(forall s3:'a1 set. +(equiv(s1,s2) -> (equiv(s2,s3) -> equiv(s1, +s3)))))) + +logic as_uint8 : int -> int + +predicate is_uint8(x:int) = ((0<=x) and (x<256)) + +axiom as_uint8_def : (forall x:int. +is_uint8(as_uint8(x))) + +axiom as_uint8_involve : (forall x:int[as_uint8(as_uint8(x))]. +(as_uint8(as_uint8(x))=as_uint8(x))) + +axiom is_as_uint8 : (forall x:int[as_uint8(x)]. +(is_uint8(x) -> (as_uint8(x)=x))) + +logic as_sint8 : int -> int + +predicate is_sint8(x:int) = (((-128)<=x) and (x<128)) + +axiom as_sint8_def : (forall x:int. +is_sint8(as_sint8(x))) + +axiom as_sint8_involve : (forall x:int[as_sint8(as_sint8(x))]. +(as_sint8(as_sint8(x))=as_sint8(x))) + +axiom is_as_sint8 : (forall x:int[as_sint8(x)]. +(is_sint8(x) -> (as_sint8(x)=x))) + +logic as_uint16 : int -> int + +predicate is_uint16(x:int) = ((0<=x) and (x<65536)) + +axiom as_uint16_def : (forall x:int. +is_uint16(as_uint16(x))) + +axiom as_uint16_involve : (forall x:int[as_uint16(as_uint16(x))]. +(as_uint16(as_uint16(x))=as_uint16(x))) + +axiom is_as_uint16 : (forall x:int[as_uint16(x)]. +(is_uint16(x) -> (as_uint16(x)=x))) + +logic as_sint16 : int -> int + +predicate is_sint16(x:int) = (((-32768)<=x) and (x<32768)) + +axiom as_sint16_def : (forall x:int. +is_sint16(as_sint16(x))) + +axiom as_sint16_involve : (forall x:int[as_sint16(as_sint16(x))]. +(as_sint16(as_sint16(x))=as_sint16(x))) + +axiom is_as_sint16 : (forall x:int[as_sint16(x)]. +(is_sint16(x) -> (as_sint16(x)=x))) + +logic as_uint32 : int -> int + +predicate is_uint32(x:int) = ((0<=x) and (x<4294967296)) + +axiom as_uint32_def : (forall x:int. +is_uint32(as_uint32(x))) + +axiom as_uint32_involve : (forall x:int[as_uint32(as_uint32(x))]. +(as_uint32(as_uint32(x))=as_uint32(x))) + +axiom is_as_uint32 : (forall x:int[as_uint32(x)]. +(is_uint32(x) -> (as_uint32(x)=x))) + +logic as_sint32 : int -> int + +predicate is_sint32(x:int) = (((-2147483648)<=x) and (x<2147483648)) + +axiom as_sint32_def : (forall x:int. +is_sint32(as_sint32(x))) + +axiom as_sint32_involve : (forall x:int[as_sint32(as_sint32(x))]. +(as_sint32(as_sint32(x))=as_sint32(x))) + +axiom is_as_sint32 : (forall x:int[as_sint32(x)]. +(is_sint32(x) -> (as_sint32(x)=x))) + +logic as_uint64 : int -> int + +predicate is_uint64(x:int) = ((0<=x) and (x<18446744073709551616)) + +axiom as_uint64_def : (forall x:int. +is_uint64(as_uint64(x))) + +axiom as_uint64_involve : (forall x:int[as_uint64(as_uint64(x))]. +(as_uint64(as_uint64(x))=as_uint64(x))) + +axiom is_as_uint64 : (forall x:int[as_uint64(x)]. +(is_uint64(x) -> (as_uint64(x)=x))) + +logic as_sint64 : int -> int + +predicate is_sint64(x:int) = (((-9223372036854775808)<=x) and (x<9223372036854775808)) + +axiom as_sint64_def : (forall x:int. +is_sint64(as_sint64(x))) + +axiom as_sint64_involve : (forall x:int[as_sint64(as_sint64(x))]. +(as_sint64(as_sint64(x))=as_sint64(x))) + +axiom is_as_sint64 : (forall x:int[as_sint64(x)]. +(is_sint64(x) -> (as_sint64(x)=x))) + +logic as_float16 : real -> real + +logic is_float16 : real -> prop + +axiom as_float16_def : (forall x:real. +is_float16(as_float16(x))) + +axiom as_float16_involve : (forall x:real[as_float16(as_float16(x))]. +(as_float16(as_float16(x))=as_float16(x))) + +axiom is_as_float16 : (forall x:real[as_float16(x)]. +(is_float16(x) -> (as_float16(x)=x))) + +logic as_float32 : real -> real + +logic is_float32 : real -> prop + +axiom as_float32_def : (forall x:real. +is_float32(as_float32(x))) + +axiom as_float32_involve : (forall x:real[as_float32(as_float32(x))]. +(as_float32(as_float32(x))=as_float32(x))) + +axiom is_as_float32 : (forall x:real[as_float32(x)]. +(is_float32(x) -> (as_float32(x)=x))) + +logic as_float64 : real -> real + +logic is_float64 : real -> prop + +axiom as_float64_def : (forall x:real. +is_float64(as_float64(x))) + +axiom as_float64_involve : (forall x:real[as_float64(as_float64(x))]. +(as_float64(as_float64(x))=as_float64(x))) + +axiom is_as_float64 : (forall x:real[as_float64(x)]. +(is_float64(x) -> (as_float64(x)=x))) + +logic as_float128 : real -> real + +logic is_float128 : real -> prop + +axiom as_float128_def : (forall x:real. +is_float128(as_float128(x))) + +axiom as_float128_involve : (forall x:real[as_float128(as_float128(x))]. +(as_float128(as_float128(x))=as_float128(x))) + +axiom is_as_float128 : (forall x:real[as_float128(x)]. +(is_float128(x) -> (as_float128(x)=x))) + +type data + +logic data_of_uint8 : int -> data + +logic uint8_of_data : data -> int + +axiom is_uint8_of_data : (forall d:data[is_uint8(uint8_of_data(d))]. +is_uint8(uint8_of_data(d))) + +axiom uint8ofdata_dataofuint8 : (forall x:int[data_of_uint8(x)]. +(is_uint8(x) -> (uint8_of_data(data_of_uint8(x))=x))) + +logic data_of_sint8 : int -> data + +logic sint8_of_data : data -> int + +axiom is_sint8_of_data : (forall d:data[is_sint8(sint8_of_data(d))]. +is_sint8(sint8_of_data(d))) + +axiom sint8ofdata_dataofsint8 : (forall x:int[data_of_sint8(x)]. +(is_sint8(x) -> (sint8_of_data(data_of_sint8(x))=x))) + +logic data_of_uint16 : int -> data + +logic uint16_of_data : data -> int + +axiom is_uint16_of_data : (forall d:data[is_uint16(uint16_of_data(d))]. +is_uint16(uint16_of_data(d))) + +axiom uint16ofdata_dataofuint16 : (forall x:int[uint16_of_data(data_of_uint16(x))]. +(is_uint16(x) -> (uint16_of_data(data_of_uint16(x))=x))) + +logic data_of_sint16 : int -> data + +logic sint16_of_data : data -> int + +axiom is_sint16_of_data : (forall d:data[is_sint16(sint16_of_data(d))]. +is_sint16(sint16_of_data(d))) + +axiom sint16ofdata_dataofsint16 : (forall x:int[data_of_sint16(x)]. +(is_sint16(x) -> (sint16_of_data(data_of_sint16(x))=x))) + +logic data_of_uint32 : int -> data + +logic uint32_of_data : data -> int + +axiom is_uint32_of_data : (forall d:data[is_uint32(uint32_of_data(d))]. +is_uint32(uint32_of_data(d))) + +axiom uint32ofdata_dataofuint32 : (forall x:int[data_of_uint32(x)]. +(is_uint32(x) -> (uint32_of_data(data_of_uint32(x))=x))) + +logic data_of_sint32 : int -> data + +logic sint32_of_data : data -> int + +axiom is_sint32_of_data : (forall d:data[is_sint32(sint32_of_data(d))]. +is_sint32(sint32_of_data(d))) + +axiom sint32ofdata_dataofsint32 : (forall x:int[data_of_sint32(x)]. +(is_sint32(x) -> (sint32_of_data(data_of_sint32(x))=x))) + +logic data_of_uint64 : int -> data + +logic uint64_of_data : data -> int + +axiom is_uint64_of_data : (forall d:data[is_uint64(uint64_of_data(d))]. +is_uint64(uint64_of_data(d))) + +axiom uint64ofdata_dataofuint64 : (forall x:int[data_of_uint64(x)]. +(is_uint64(x) -> (uint64_of_data(data_of_uint64(x))=x))) + +logic data_of_sint64 : int -> data + +logic sint64_of_data : data -> int + +axiom is_sint64_of_data : (forall d:data[is_sint64(sint64_of_data(d))]. +is_sint64(sint64_of_data(d))) + +axiom sint64ofdata_dataofsint64 : (forall x:int[data_of_sint64(x)]. +(is_sint64(x) -> (sint64_of_data(data_of_sint64(x))=x))) + +logic data_of_float16 : real -> data + +logic float16_of_data : data -> real + +axiom is_float16_of_data : (forall d:data[is_float16(float16_of_data(d))]. +is_float16(float16_of_data(d))) + +axiom float16ofdata_dataoffloat16 : (forall x:real[data_of_float16(x)]. +(is_float16(x) -> (float16_of_data(data_of_float16(x))=x))) + +logic data_of_float32 : real -> data + +logic float32_of_data : data -> real + +axiom is_float32_of_data : (forall d:data[is_float32(float32_of_data(d))]. +is_float32(float32_of_data(d))) + +axiom float32ofdata_dataoffloat32 : (forall x:real[data_of_float32(x)]. +(is_float32(x) -> (float32_of_data(data_of_float32(x))=x))) + +logic data_of_float64 : real -> data + +logic float64_of_data : data -> real + +axiom is_float64_of_data : (forall d:data[is_float64(float64_of_data(d))]. +is_float64(float64_of_data(d))) + +axiom float64ofdata_dataoffloat64 : (forall x:real[data_of_float64(x)]. +(is_float64(x) -> (float64_of_data(data_of_float64(x))=x))) + +logic data_of_float128 : real -> data + +logic float128_of_data : data -> real + +axiom is_float128_of_data : (forall d:data[is_float128(float128_of_data(d))]. +is_float128(float128_of_data(d))) + +axiom float128ofdata_dataoffloat128 : (forall x:real[data_of_float128(x)]. +(is_float128(x) -> (float128_of_data(data_of_float128(x))=x))) + +logic set_range_index : 'a1 farray,int set,int -> 'a1 farray + +axiom set_range_def : (forall t:'a1 farray.(forall rg:int set.(forall k:int. +(forall i:int[set_range_index(t,rg,k)[i]].((not member(i, +rg)) -> (set_range_index(t,rg,k)[i]=t[i])))))) + +logic bnot : int -> int + +logic band : int,int -> int + +logic bor : int,int -> int + +logic bxor : int,int -> int + +logic lshift : int,int -> int + +logic rshift : int,int -> int + +logic int_not : int -> int + +logic int_and : int,int -> int + +logic int_or : int,int -> int + +logic int_xor : int,int -> int + +logic int_lsh : int,int -> int + +logic int_rshs : int,int -> int + +logic int_rshu : int,int -> int + +type 'a format + +logic format_size : 'a1 format -> int + +logic is_in_format : 'a1 format,'a1 -> prop + +logic signed_format : int format -> bool + +logic uint8_format : int format + +axiom uint8_format_size : (format_size(uint8_format)=8) + +axiom uint8_format_sign : (signed_format(uint8_format)=false) + +logic sint8_format : int format + +axiom sint8_format_size : (format_size(sint8_format)=8) + +axiom sint8_format_sign : (signed_format(sint8_format)=true) + +logic uint16_format : int format + +axiom uint16_format_size : (format_size(uint16_format)=16) + +axiom uint16_format_sign : (signed_format(uint16_format)=false) + +logic sint16_format : int format + +axiom sint16_format_size : (format_size(sint16_format)=16) + +axiom sint16_format_sign : (signed_format(sint16_format)=true) + +logic uint32_format : int format + +axiom uint32_format_size : (format_size(uint32_format)=32) + +axiom uint32_format_sign : (signed_format(uint32_format)=false) + +logic sint32_format : int format + +axiom sint32_format_size : (format_size(sint32_format)=32) + +axiom sint32_format_sign : (signed_format(sint32_format)=true) + +logic uint64_format : int format + +axiom uint64_format_size : (format_size(uint64_format)=64) + +axiom uint64_format_sign : (signed_format(uint64_format)=false) + +logic sint64_format : int format + +axiom sint64_format_size : (format_size(sint64_format)=64) + +axiom sint64_format_sign : (signed_format(sint64_format)=true) + +axiom is_in_format_sint8 : (forall x:int[is_in_format(sint8_format,x)]. +(is_in_format(sint8_format, +x) <-> (((-128)<=x) and (x<128)))) + +axiom is_in_format_uint8 : (forall x:int[is_in_format(uint8_format,x)]. +(is_in_format(uint8_format, +x) <-> ((0<=x) and (x<256)))) + +axiom is_in_format_sint16 : (forall x:int[is_in_format(sint16_format,x)]. +(is_in_format(sint16_format, +x) <-> (((-32768)<=x) and (x<32768)))) + +axiom is_in_format_uint16 : (forall x:int[is_in_format(uint16_format,x)]. +(is_in_format(uint16_format, +x) <-> ((0<=x) and (x<65536)))) + +axiom is_in_format_sint32 : (forall x:int[is_in_format(sint32_format,x)]. +(is_in_format(sint32_format, +x) <-> (((-2147483648)<=x) and (x<2147483648)))) + +axiom is_in_format_uint32 : (forall x:int[is_in_format(uint32_format,x)]. +(is_in_format(uint32_format, +x) <-> ((0<=x) and (x<4294967296)))) + +axiom is_in_format_sint64 : (forall x:int[is_in_format(sint64_format,x)]. +(is_in_format(sint64_format, +x) <-> (((-9223372036854775808)<=x) and (x<9223372036854775808)))) + +axiom is_in_format_uint64 : (forall x:int[is_in_format(uint64_format,x)]. +(is_in_format(uint64_format, +x) <-> ((0<=x) and (x<18446744073709551616)))) + +logic float16_format : real format + +axiom float16_format_size : (format_size(float16_format)=16) + +logic float32_format : real format + +axiom float32_format_size : (format_size(float32_format)=32) + +logic float64_format : real format + +axiom float64_format_size : (format_size(float64_format)=64) + +logic float96_format : real format + +axiom float96_format_size : (format_size(float96_format)=96) + +logic float128_format : real format + +axiom float128_format_size : (format_size(float128_format)=128) + +logic encode : 'a1 format,'a1 -> data + +logic decode : 'a1 format,data -> 'a1 + +axiom encode_decode : (forall f:'a1 format.(forall d:data. +(encode(f,decode(f,d))=d))) + +axiom decode_encode : (forall f:'a1 format.(forall x:'a1. +(decode(f,encode(f,x))=x))) + +axiom decode_inj : (forall d:data.(forall d':data.(forall f:'a1 format. +((decode(f,d)<>decode(f,d')) <-> (d<>d'))))) + +axiom decode_eq : (forall d:data.(forall d':data.(forall f:'a1 format. +((decode(f,d)=decode(f,d')) <-> (d=d'))))) + +logic int_format : int format + +logic real_format : real format + +logic as_int : int format,int -> int + +axiom simpl_as_int : (forall f:int format.(forall x:int.(is_in_format(f, +x) -> (as_int(f,x)=x)))) + +axiom as_int_def : (forall f:int format.(forall x:int.is_in_format(f, +as_int(f,x)))) + +axiom involve_as_int : (forall f:int format.(forall x:int. +(as_int(f,as_int(f,x))=as_int(f,x)))) + +logic as_float : real format,real -> real + +axiom simpl_as_float : (forall f:real format.(forall x:real.(is_in_format(f, +x) -> (as_float(f,x)=x)))) + +axiom as_float_def : (forall f:real format.(forall x:real.is_in_format(f, +as_float(f,x)))) + +axiom involve_as_float : (forall f:real format.(forall x:real. +(as_float(f,as_float(f,x))=as_float(f,x)))) + +type zone + +logic rt_zone : int,int -> zone + +logic z_addr : zone -> int + +logic z_size : zone -> int + +axiom addr_zone : (forall a:int.(forall sz:int. +(z_addr(rt_zone(a,sz))=a))) + +axiom size_zone : (forall a:int.(forall sz:int. +((0<=sz) -> (z_size(rt_zone(a,sz))=sz)))) + +axiom rt_zone_inj : (forall a1:int.(forall a2:int.(forall sz1:int. +(forall sz2:int. +((rt_zone(a1,sz1)=rt_zone(a2,sz2)) <-> ((a1=a2) and (sz1=sz2))))))) + +predicate rt_disj(z1:zone,z2:zone) = (((z_addr(z1)+z_size(z1))<=z_addr(z2)) or ((z_addr(z2)+z_size(z2))<=z_addr(z1))) + +predicate rt_incl(z1:zone,z2:zone) = ((z_addr(z2)<=z_addr(z1)) and ((z_addr(z1)+z_size(z1))<=(z_addr(z2)+z_size(z2)))) + +predicate addr_in_zone(a:int,z:zone) = ((z_addr(z)<=a) and (a<(z_addr(z)+z_size(z)))) + +function rt_shift(addr:int,offset:int) : int = (addr+offset) + +logic rt_foffset : int -> int + +logic rt_fsize : int -> int + +logic rt_fformat : int -> int format + +type zones + +logic zs_empty : zones + +logic zs_singleton : zone -> zones + +logic zs_union : zones,zones -> zones + +logic zs_incl : zones,zones -> prop + +logic zs_disj : zones,zones -> prop + +predicate zs_z_incl(z:zone,zs:zones) = zs_incl(zs_singleton(z), +zs) + +predicate zs_z_disj(z:zone,zs:zones) = zs_disj(zs_singleton(z), +zs) + +axiom zs_empty_incl : (forall zs:zones.zs_incl(zs_empty, +zs)) + +axiom zs_z_not_incl_empty : (forall z:zone.(not zs_incl(zs_singleton(z), +zs_empty))) + +axiom zs_incl_singleton : (forall z1:zone.(forall z2:zone.(rt_incl(z1, +z2) <-> zs_incl(zs_singleton(z1), +zs_singleton(z2))))) + +axiom zs_incl_union_1 : (forall z:zones.(forall z1:zones.(forall z2:zones. +(zs_incl(z,z1) -> zs_incl(z, +zs_union(z1,z2)))))) + +axiom zs_incl_union_2 : (forall z:zones.(forall z1:zones.(forall z2:zones. +(zs_incl(z,z2) -> zs_incl(z, +zs_union(z1,z2)))))) + +axiom zs_incl_union_3 : (forall z:zones.(forall z1:zones.(forall z2:zones. +(zs_incl(z1,z) -> (zs_incl(z2,z) -> zs_incl(zs_union(z1,z2), +z)))))) + +axiom zs_disj_singleton : (forall z1:zone.(forall z2:zone.(rt_disj(z1, +z2) <-> zs_disj(zs_singleton(z1), +zs_singleton(z2))))) + +axiom zs_incl_disj : (forall z:zones.(forall zi:zones.(forall zd:zones. +(zs_incl(zi,z) -> (zs_disj(zd,z) -> zs_disj(zi, +zd)))))) + +type bits + +logic bits_size : bits -> int + +axiom bits_size_pos : (forall b:bits. +(bits_size(b)>=0)) + +logic nth_bit : bits,int -> bool + +axiom eq_bits : (forall b1:bits.(forall b2:bits.(forall sz:int. +((bits_size(b1)=sz) -> ((bits_size(b2)=sz) -> ((forall i:int. +(((0<=i) and (i<sz)) -> (nth_bit(b1,i)=nth_bit(b2,i)))) <-> (b1=b2))))))) + +predicate zero_bits(b:bits) = (forall i:int. +(((0<=i) and (i<bits_size(b))) -> (nth_bit(b,i)=false))) + +logic bits_part : bits,int,int -> bits + +axiom bits_part_size : (forall b:bits.(forall off:int.(forall sz:int. +((0<=off) -> (((off+sz)<=bits_size(b)) -> (bits_size(bits_part(b,off,sz))=sz)))))) + +axiom nth_bits_part : (forall b:bits.(forall off:int.(forall i:int. +(forall sz:int. +(((0<=i) and (i<sz)) -> ((0<=off) -> (((off+sz)<=bits_size(b)) -> (nth_bit(bits_part(b,off,sz),i)=nth_bit(b,(off+i)))))))))) + +logic bits_concat : bits,bits -> bits + +axiom bits_concat_size : (forall b1:bits.(forall b2:bits. +(bits_size(bits_concat(b1,b2))=(bits_size(b1)+bits_size(b2))))) + +axiom nth_bits_concat_l : (forall b1:bits.(forall b2:bits.(forall i:int. +(((0<=i) and (i<bits_size(b1))) -> (nth_bit(bits_concat(b1,b2),i)=nth_bit(b1,i)))))) + +axiom nth_bits_concat_r : (forall b1:bits.(forall b2:bits.(forall i:int. +(forall sz1:int.(forall sz2:int. +((sz1=bits_size(b1)) -> ((sz2=bits_size(b2)) -> (((sz1<=i) and (i<(sz1+sz2))) -> (nth_bit(bits_concat(b1,b2),i)=nth_bit(b2,(i-sz1))))))))))) + +logic wr_bits_part : bits,int,bits -> bits + +axiom wr_bits_part_size : (forall b:bits.(forall bw:bits.(forall o:int. +(bits_size(wr_bits_part(b,o,bw))=bits_size(b))))) + +axiom nth_wr_bits_part_1 : (forall b:bits.(forall b':bits.(forall off:int. +(forall i:int. +(((0<=i) and (i<off)) -> (nth_bit(wr_bits_part(b,off,b'),i)=nth_bit(b,i))))))) + +axiom nth_wr_bits_part_2 : (forall b:bits.(forall b':bits.(forall off:int. +(forall i:int. +((((0<=off) and (off<=i)) and (i<(off+bits_size(b')))) -> (nth_bit(wr_bits_part(b,off,b'),i)=nth_bit(b',(i-off)))))))) + +axiom nth_wr_bits_part_3 : (forall b:bits.(forall b':bits.(forall off:int. +(forall i:int. +((((0<=(off+bits_size(b'))) and ((off+bits_size(b'))<=i)) and (i<bits_size(b))) -> (nth_bit(wr_bits_part(b,off,b'),i)=nth_bit(b,i))))))) + +logic rt_from_bits : bits,'a1 format -> 'a1 + +axiom rt_from_bits_format : (forall b:bits.(forall fmt:'a1 format. +((bits_size(b)=format_size(fmt)) -> is_in_format(fmt, +rt_from_bits(b,fmt))))) + +logic rt_to_bits : 'a1 format,'a1 -> bits + +axiom rt_to_bits_size : (forall fmt:'a1 format. +(forall x:'a1[bits_size(rt_to_bits(fmt,x))]. +(bits_size(rt_to_bits(fmt,x))=format_size(fmt)))) + +axiom rt_to_bits_from_bits : (forall fmt:'a1 format. +(forall b:bits[rt_to_bits(fmt,rt_from_bits(b,fmt))]. +((bits_size(b)=format_size(fmt)) -> (rt_to_bits(fmt,rt_from_bits(b,fmt))=b)))) + +axiom rt_from_bits_to_bits : (forall fmt:'a1 format. +(forall v:'a1[rt_from_bits(rt_to_bits(fmt,v),fmt)].(is_in_format(fmt, +v) -> (rt_from_bits(rt_to_bits(fmt,v),fmt)=v)))) + +axiom same_int_val_same_bits : (forall b1:bits.(forall b2:bits. +(forall fmt:int format. +((bits_size(b1)=format_size(fmt)) -> ((bits_size(b2)=format_size(fmt)) -> ((rt_from_bits(b1,fmt)=rt_from_bits(b2,fmt)) -> (b1=b2))))))) + +axiom rt_to_bits_zero : (forall fmt:int format.(forall b:bits. +((b=rt_to_bits(fmt,0)) -> zero_bits(b)))) + +axiom rt_from_bits_zero : (forall b:bits.(forall fmt:int format. +(zero_bits(b) -> (rt_from_bits(b,fmt)=0)))) + +logic mbyte_to_bbits : bits -> bool farray + +axiom mbyte_to_bbits_def : (forall b:bits.((bits_size(b)=8) -> (forall i:int. +(((0<=i) and (i<8)) -> (mbyte_to_bbits(b)[i]=nth_bit(b,(7-i))))))) + +logic nth_mbyte : int,bits -> bits + +axiom nth_mbyte_size : (forall b:bits.(forall k:int. +(bits_size(nth_mbyte(k,b))=8))) + +axiom nth_byte_def : (forall b:bits.(forall k:int. +(((0<=(8(k+1))) and ((8(k+1))<=bits_size(b))) -> (forall i:int. +(((0<=i) and (i<8)) -> (nth_bit(nth_mbyte(k,b),i)=nth_bit(b,((8k)+i)))))))) + +function nth_byte(k:int,b:bits) : bool farray = mbyte_to_bbits(nth_mbyte(k,b)) + +logic little_endian : prop + +logic concat_bytes : bool farray,bool farray -> bool farray + +axiom concat_bytes_left : (forall w:bool farray.(forall b:bool farray. +(forall i:int. +((8<=i) -> (concat_bytes(w,b)[i]=w[(i-8)]))))) + +axiom concat_bytes_right : (forall w:bool farray.(forall b:bool farray. +(forall i:int. +(((0<=i) and (i<8)) -> (concat_bytes(w,b)[i]=b[i]))))) + +logic uint_of_bits : int,bool farray -> int + +logic sint_of_bits : int,bool farray -> int + +function cint_of_bits(fmt:int format,b:bool farray) : int = ite(signed_format(fmt),sint_of_bits((format_size(fmt)-1),b),uint_of_bits((format_size(fmt)-1),b)) + +logic bits_of_sint : int,int -> bool farray + +logic bits_of_uint : int,int -> bool farray + +function bits_of_cint(fmt:int format,x:int) : bool farray = ite(signed_format(fmt),bits_of_sint((format_size(fmt)-1),x),bits_of_uint((format_size(fmt)-1),x)) + +logic mbits_to_bbits : bits -> bool farray + +axiom mb8_to_bbits : (forall b:bits. +((bits_size(b)=8) -> (mbits_to_bbits(b)=nth_byte(0,b)))) + +axiom little_mb16_to_bbits : (forall b:bits. +((bits_size(b)=16) -> (little_endian -> (mbits_to_bbits(b)=concat_bytes(nth_byte(1,b),nth_byte(0,b)))))) + +axiom big_mb16_to_bbits : (forall b:bits. +((bits_size(b)=16) -> ((not little_endian) -> (mbits_to_bbits(b)=concat_bytes(nth_byte(0,b),nth_byte(1,b)))))) + +axiom little_mb32_to_bbits : (forall b:bits. +((bits_size(b)=32) -> (little_endian -> (mbits_to_bbits(b)=concat_bytes(concat_bytes(concat_bytes(nth_byte(3,b),nth_byte(2,b)),nth_byte(1,b)),nth_byte(0,b)))))) + +axiom big_mb32_to_bbits : (forall b:bits. +((bits_size(b)=32) -> ((not little_endian) -> (mbits_to_bbits(b)=concat_bytes(concat_bytes(concat_bytes(nth_byte(0,b),nth_byte(1,b)),nth_byte(2,b)),nth_byte(3,b)))))) + +axiom rt_int_from_bits : (forall b:bits.(forall fmt:int format. +(rt_from_bits(b,fmt)=cint_of_bits(fmt,mbits_to_bbits(b))))) + +logic bbits_to_mbyte : int,bool farray -> bits + +axiom bbits_to_mbyte_size : (forall b:bool farray.(forall k:int. +(bits_size(bbits_to_mbyte(k,b))=8))) + +axiom bbits_to_mbyte_def : (forall b:bool farray.(forall k:int.(forall i:int. +(((0<=i) and (i<8)) -> (nth_bit(bbits_to_mbyte(k,b),i)=b[(((8k)+7)-i)]))))) + +logic bbits_to_mbits : int,bool farray -> bits + +axiom bbits_to_mb8 : (forall b:bool farray. +(bbits_to_mbits(8,b)=bbits_to_mbyte(0,b))) + +axiom bbits_to_little_mb16 : (forall b:bool farray. +(little_endian -> (bbits_to_mbits(16,b)=bits_concat(bbits_to_mbyte(0,b),bbits_to_mbyte(1,b))))) + +axiom bbits_to_big_mb16 : (forall b:bool farray. +((not little_endian) -> (bbits_to_mbits(16,b)=bits_concat(bbits_to_mbyte(1,b),bbits_to_mbyte(0,b))))) + +axiom bbits_to_little_mb32 : (forall b:bool farray. +(little_endian -> (bbits_to_mbits(32,b)=bits_concat(bbits_to_mbyte(0,b),bits_concat(bbits_to_mbyte(1,b),bits_concat(bbits_to_mbyte(2,b),bbits_to_mbyte(3,b))))))) + +axiom bbits_to_not_mb32 : (forall b:bool farray. +((not little_endian) -> (bbits_to_mbits(32,b)=bits_concat(bbits_to_mbyte(3,b),bits_concat(bbits_to_mbyte(2,b),bits_concat(bbits_to_mbyte(1,b),bbits_to_mbyte(0,b))))))) + +axiom rt_int_to_bits : (forall x:int.(forall fmt:int format. +(rt_to_bits(fmt,x)=bbits_to_mbits(format_size(fmt),bits_of_cint(fmt,x))))) + +type memory + +type memalloc + +logic rt_valid : memalloc,zone -> prop + +axiom incl_valid : (forall m:memalloc.(forall z:zone.(forall z':zone. +(rt_incl(z',z) -> (rt_valid(m,z) -> rt_valid(m, +z')))))) + +axiom disj_valid : (forall m:memalloc.(forall z:zone. +(forall z':zone[rt_disj(z,z')].(rt_valid(m,z) -> ((not rt_valid(m, +z')) -> rt_disj(z, +z')))))) + +logic rt_zbase : memalloc,int -> zone + +function rt_abase(m:memalloc,addr:int) : int = z_addr(rt_zbase(m,addr)) + +logic rt_block_length : memalloc,int -> int + +type mz + +logic mem_of_mz : mz -> memalloc + +logic addr_of_mz : mz -> int + +logic rt_alloc : memalloc,int -> mz + +function alloc_zone(m:memalloc,sz:int) : zone = rt_zone(addr_of_mz(rt_alloc(m,sz)),sz) + +axiom alloc_is_base : (forall m:memalloc.(forall sz:int. +(rt_zbase(mem_of_mz(rt_alloc(m,sz)),addr_of_mz(rt_alloc(m,sz)))=alloc_zone(m,sz)))) + +axiom valid_alloc : (forall m:memalloc.(forall sz:int. +rt_valid(mem_of_mz(rt_alloc(m,sz)), +alloc_zone(m,sz)))) + +axiom not_valid_before_alloc : (forall m:memalloc.(forall sz:int. +(not rt_valid(m, +alloc_zone(m,sz))))) + +axiom alloc_keep_valid : (forall m:memalloc.(forall sz:int.(forall z:zone. +(rt_valid(m,z) -> rt_valid(mem_of_mz(rt_alloc(m,sz)), +z))))) + +axiom alloc_keep_invalid : (forall m:memalloc.(forall sz:int.(forall z:zone. +(rt_valid(mem_of_mz(rt_alloc(m,sz)),z) -> (rt_disj(alloc_zone(m,sz), +z) -> rt_valid(m, +z)))))) + +logic rt_free : memalloc,int -> memalloc + +axiom not_valid_after_free : (forall m:memalloc.(forall addr:int. +(forall z:zone. +((z=rt_zbase(m,addr)) -> ((addr=z_addr(z)) -> (not rt_valid(rt_free(m,addr), +z))))))) + +axiom valid_free_disj : (forall m:memalloc.(forall z:zone.(forall z':zone. +(rt_valid(rt_free(m,z_addr(z)),z') <-> rt_disj(z, +z'))))) + +logic rt_vaddr : memalloc,int -> int + +logic rt_vsize : int -> int + +function rt_vzone(ma:memalloc,var:int) : zone = rt_zone(rt_vaddr(ma,var),rt_vsize(var)) + +logic rt_global : int -> prop + +axiom rt_global_vaddr : (forall v:int.(rt_global(v) -> (forall ma:memalloc. +(forall ma':memalloc. +(rt_vaddr(ma,v)=rt_vaddr(ma',v)))))) + +axiom rt_global_valid : (forall ma:memalloc.(forall v:int. +(rt_global(v) -> (forall ma:memalloc. +(forall ma':memalloc[rt_valid(ma,rt_vzone(ma',v))].rt_valid(ma, +rt_vzone(ma',v))))))) + +axiom vzone_disj : (forall ma:memalloc.(forall v1:int.(forall v2:int. +((v1<>v2) -> (rt_valid(ma,rt_vzone(ma,v1)) -> (rt_valid(ma, +rt_vzone(ma,v2)) -> rt_disj(rt_vzone(ma,v1), +rt_vzone(ma,v2)))))))) + +logic rt_valloc : memalloc,int -> memalloc + +axiom rt_valloc_mem : (forall ma:memalloc.(forall var:int. +(rt_valloc(ma,var)=mem_of_mz(rt_alloc(ma,rt_vsize(var)))))) + +axiom rt_valloc_addr : (forall ma:memalloc.(forall var:int. +(forall ma':memalloc.((ma'=rt_valloc(ma,var)) -> (forall mz:mz. +((mz=rt_alloc(ma,rt_vsize(var))) -> (rt_vaddr(ma',var)=addr_of_mz(mz)))))))) + +axiom vzone_valloc_neq : (forall ma:memalloc.(forall v1:int.(forall v2:int. +(forall ma':memalloc. +((ma'=rt_valloc(ma,v1)) -> ((v1<>v2) -> (rt_vzone(ma',v2)=rt_vzone(ma,v2)))))))) + +function rt_vfree(ma:memalloc,var:int) : memalloc = rt_free(ma,rt_vaddr(ma,var)) + +axiom rt_vaddr_vfree : (forall ma:memalloc.(forall v1:int.(forall v2:int. +((v1<>v2) -> (rt_vaddr(rt_vfree(ma,v1),v2)=rt_vaddr(ma,v2)))))) + +axiom addr_base : (forall m:memalloc.(forall v:int. +(rt_abase(m,rt_vaddr(m,v))=rt_vaddr(m,v)))) + +logic rt_load : memory,zone -> bits + +logic rt_store : memory,int,bits -> memory + +axiom load_store_same : (forall m:memory.(forall a:int.(forall z:zone. +(forall v:bits[rt_load(rt_store(m,a,v),z)]. +((z=rt_zone(a,bits_size(v))) -> (rt_load(rt_store(m,a,v),z)=v)))))) + +axiom load_store_disj : (forall m:memory.(forall a:int.(forall z:zone. +(forall v:bits[rt_load(rt_store(m,a,v),z)].(rt_disj(rt_zone(a,bits_size(v)), +z) -> (rt_load(rt_store(m,a,v),z)=rt_load(m,z))))))) + +axiom load_store_incl_part : (forall m:memory.(forall a:int.(forall z1:zone. +(forall z2:zone.(forall v:bits.((z2=rt_zone(a,bits_size(v))) -> (rt_incl(z1, +z2) -> (rt_load(rt_store(m,a,v),z1)=bits_part(v,(z_addr(z1)-a),z_size(z1)))))))))) + +axiom load_incl_part_store : (forall m:memory.(forall z1:zone. +(forall z2:zone.(forall v:bits.(forall a:int. +((z1=rt_zone(a,bits_size(v))) -> (forall off:int. +((off=(a-z_addr(z2))) -> (rt_incl(z1, +z2) -> (rt_load(rt_store(m,a,v),z2)=wr_bits_part(rt_load(m,z2),off,v))))))))))) + +axiom rt_load_size : (forall m:memory.(forall z:zone. +(bits_size(rt_load(m,z))=z_size(z)))) + +axiom bits_part_rt_load : (forall z:zone.(forall z':zone.(forall a':int. +(forall off:int.(forall sz:int. +((a'=(z_addr(z)+off)) -> ((z'=rt_zone(a',sz)) -> (rt_incl(z', +z) -> (forall m:memory. +(rt_load(m,z')=bits_part(rt_load(m,z),off,sz))))))))))) + +axiom rt_same_mem : (forall m1:memory.(forall m2:memory.((forall z:zone. +(rt_load(m1,z)=rt_load(m2,z))) -> (m1=m2)))) + +logic rt_havoc : memory,zone -> memory + +predicate rt_is_havoc(ma:memalloc,m1:memory,zs:zones,m2:memory) = (forall z:zone. +(rt_valid(ma,z) -> (zs_z_disj(z, +zs) -> (rt_load(m1,z)=rt_load(m2,z))))) + +axiom rt_havoc_is_havoc : (forall ma:memalloc.(forall m:memory. +(forall zs:zones.(forall z:zone.(zs_z_incl(z,zs) -> rt_is_havoc(ma,m,zs, +rt_havoc(m,z))))))) + +logic rt_addr_format : int format + +axiom rt_vaddr_format : (forall ma:memalloc.(forall v:int. +is_in_format(rt_addr_format, +rt_vaddr(ma,v)))) + +axiom bits_part_vs_access : (forall bs:bits.(forall fs:data farray format. +(forall f:int.(forall off:int.(forall sz:int. +((off=rt_foffset(f)) -> ((sz=rt_fsize(f)) -> (rt_from_bits(bits_part(bs,off,sz),rt_fformat(f))=decode(int_format,rt_from_bits(bs,fs)[f]))))))))) + +logic rt_addr_lt : int,int -> prop + +logic rt_addr_le : int,int -> prop + +logic rt_addr_lt_bool : int,int -> bool + +logic rt_addr_le_bool : int,int -> bool + +logic rt_addr_minus : int,int -> int + +logic rt_addr_eq : int,int -> prop + +logic rt_addr_eq_bool : int,int -> bool + +axiom rt_disj_sym : (forall z1:zone.(forall z2:zone.(rt_disj(z1, +z2) <-> rt_disj(z2, +z1)))) + +axiom rt_disj_shift : (forall addr:int.(forall i:int.(forall j:int. +(forall sz:int. +((sz>0) -> ((i<>j) -> rt_disj(rt_zone(rt_shift(addr,(isz)),sz), +rt_zone(rt_shift(addr,(jsz)),sz)))))))) + +axiom vzone_of_zone : (forall ma:memalloc.(forall v:int.(forall a:int. +(forall sz:int. +((a=rt_vaddr(ma,v)) -> ((sz=rt_vsize(v)) -> (rt_zone(a,sz)=rt_vzone(ma,v)))))))) + +axiom bits_part_full : (forall v:bits.(forall sz:int. +((sz=bits_size(v)) -> (bits_part(v,0,sz)=v)))) + +axiom bits_part_of_bits_part : (forall b:bits.(forall o1:int.(forall o2:int. +(forall sz1:int.(forall sz2:int. +((0<=o1) -> (((o1+sz1)<=bits_size(b)) -> ((0<=o2) -> (((o2+sz2)<=sz1) -> (bits_part(bits_part(b,o1,sz1),o2,sz2)=bits_part(b,(o1+o2),sz2))))))))))) + +axiom eq_bits_split : (forall b1:bits.(forall b2:bits.(forall sz:int. +((bits_size(b1)=sz) -> ((bits_size(b2)=sz) -> (forall sz1:int. +(forall sz2:int. +((sz1>=0) -> ((sz2>=0) -> (((sz1+sz2)=sz) -> ((bits_part(b1,0,sz1)=bits_part(b2,0,sz1)) -> ((bits_part(b1,sz1,sz2)=bits_part(b2,sz1,sz2)) -> (b1=b2))))))))))))) + +axiom wr_bits_part_all : (forall v:bits.(forall v':bits. +((bits_size(v)=bits_size(v')) -> (wr_bits_part(v,0,v')=v')))) + +axiom wr_bits_part_concat : (forall b:bits.(forall b':bits.(forall sz1:int. +(forall sz2:int.(forall sz3:int. +((0<=sz1) -> ((sz2=bits_size(b')) -> ((0<=sz3) -> ((((sz1+sz2)+sz3)=bits_size(b)) -> (wr_bits_part(b,sz1,b')=bits_concat(bits_part(b,0,sz1),bits_concat(b',bits_part(b,(sz1+sz2),sz3))))))))))))) + +axiom wr_bits_part_same : (forall b1:bits.(forall b2:bits.(forall off:int. +((0<=off) -> (((off+bits_size(b2))<=bits_size(b1)) -> (bits_part(wr_bits_part(b1,off,b2),off,bits_size(b2))=b2)))))) + +axiom wr_bits_part_disj : (forall b:bits.(forall b1:bits.(forall off2:int. +(forall off1:int.(forall sz:int.(forall sz1:int.(forall sz2:int. +((sz=bits_size(b)) -> ((sz1=bits_size(b1)) -> ((0<=off1) -> (((off1+sz1)<=sz) -> ((0<=off2) -> (((off2+sz2)<=sz) -> ((((off2+sz2)<=off1) or ((off1+sz1)<=off2)) -> (bits_part(wr_bits_part(b,off1,b1),off2,sz2)=bits_part(b,off2,sz2)))))))))))))))) + +axiom rt_z_from_bits_to_bits_zero : (forall fmt:int format. +(forall fmt':int format. +(rt_from_bits(rt_to_bits(fmt,0),fmt')=0))) + +axiom bits_part_zero : (forall b:bits.(forall b':bits.(forall off:int. +(forall sz:int. +((0<=off) -> (((off+sz)<=bits_size(b)) -> ((b'=bits_part(b,off,sz)) -> (zero_bits(b) -> zero_bits(b'))))))))) + +axiom rw_same_var : (forall m:memory.(forall ma:memalloc.(forall v:int. +(forall val:bits[rt_load(rt_store(m,rt_vaddr(ma,v),val),rt_vzone(ma,v))]. +((bits_size(val)=rt_vsize(v)) -> (rt_load(rt_store(m,rt_vaddr(ma,v),val),rt_vzone(ma,v))=val)))))) + +axiom rw_disj_var : (forall ma:memalloc.(forall m:memory.(forall v1:int. +(forall v2:int.(forall z1:zone.(forall z2:zone. +(forall b:bits[rt_load(rt_store(m,rt_vaddr(ma,v2),b),rt_vzone(ma,v1))]. +((v1<>v2) -> ((z1=rt_vzone(ma,v1)) -> ((z2=rt_vzone(ma,v2)) -> (rt_valid(ma, +z1) -> (rt_valid(ma, +z2) -> ((rt_vsize(v2)=bits_size(b)) -> (rt_load(rt_store(m,rt_vaddr(ma,v2),b),z1)=rt_load(m,z1))))))))))))))) + +axiom store_concat : (forall m:memory.(forall m1:memory.(forall a:int. +(forall b1:bits.(forall b2:bits.(forall sz1:int. +((sz1=bits_size(b1)) -> ((m1=rt_store(m,a,b1)) -> (rt_store(m1,(a+sz1),b2)=rt_store(m,a,bits_concat(b1,b2))))))))))) + +axiom store_disj_commut : (forall m:memory.(forall a1:int.(forall a2:int. +(forall b1:bits.(forall b2:bits.(rt_disj(rt_zone(a1,bits_size(b1)), +rt_zone(a2,bits_size(b2))) -> (rt_store(rt_store(m,a1,b1),a2,b2)=rt_store(rt_store(m,a2,b2),a1,b1)))))))) + +axiom not_valid_before_valloc : (forall ma:memalloc.(forall v:int. +(forall ma':memalloc.((ma'=rt_valloc(ma,v)) -> (not rt_valid(ma, +rt_vzone(ma',v))))))) + +axiom valid_valloc : (forall ma:memalloc.(forall v:int. +(forall ma':memalloc[rt_valid(ma',rt_vzone(ma',v))]. +((ma'=rt_valloc(ma,v)) -> rt_valid(ma', +rt_vzone(ma',v)))))) + +axiom valloc_keep_valid_zone : (forall ma:memalloc.(forall v:int. +(forall ma':memalloc.((ma'=rt_valloc(ma,v)) -> (forall z:zone.(rt_valid(ma, +z) -> rt_valid(ma', +z))))))) + +axiom valloc_keep_valid_disj_zone : (forall ma:memalloc.(forall v:int. +(forall ma':memalloc.((ma'=rt_valloc(ma,v)) -> (forall z:zone. +(rt_disj(rt_vzone(ma',v),z) -> (rt_valid(ma',z) -> rt_valid(ma, +z)))))))) + +axiom valloc_keep_invalid_zone : (forall ma:memalloc.(forall v:int. +(forall ma':memalloc.((ma'=rt_valloc(ma,v)) -> (forall z:zone. +(rt_disj(rt_vzone(ma',v),z) -> ((not rt_valid(ma,z)) -> (not rt_valid(ma', +z))))))))) + +axiom valloc_keep_invalid_zone_rev : (forall ma:memalloc.(forall v:int. +(forall ma':memalloc.((ma'=rt_valloc(ma,v)) -> (forall z:zone. +(rt_disj(rt_vzone(ma',v),z) -> ((not rt_valid(ma',z)) -> (not rt_valid(ma, +z))))))))) + +axiom valloc_keep_valid_var : (forall ma:memalloc.(forall v1:int. +(forall v:int.(forall ma':memalloc. +((ma'=rt_valloc(ma,v)) -> ((v<>v1) -> (rt_valid(ma, +rt_vzone(ma,v1)) -> rt_valid(ma', +rt_vzone(ma',v1))))))))) + +axiom valloc_keep_vaddr : (forall ma:memalloc.(forall v1:int.(forall v:int. +(forall ma':memalloc. +((ma'=rt_valloc(ma,v)) -> ((v<>v1) -> (rt_vaddr(ma',v1)=rt_vaddr(ma,v1)))))))) + +axiom valloc_keep_vzone : (forall ma:memalloc.(forall v1:int.(forall v:int. +(forall ma':memalloc. +((ma'=rt_valloc(ma,v)) -> ((v<>v1) -> (rt_vzone(ma',v1)=rt_vzone(ma,v1)))))))) + +axiom vzone_vfree : (forall ma:memalloc.(forall v1:int.(forall v2:int. +(forall ma':memalloc. +((ma'=rt_vfree(ma,v1)) -> ((v1<>v2) -> (rt_vzone(ma',v2)=rt_vzone(ma,v2)))))))) + +axiom not_valid_after_vfree : (forall ma:memalloc.(forall v:int. +(forall ma':memalloc.((ma'=rt_vfree(ma,v)) -> (forall z:zone. +((z=rt_vzone(ma,v)) -> (not rt_valid(ma', +z)))))))) + +axiom havoc_store : (forall ma:memalloc.(forall m1:memory.(forall m2:memory. +(forall zs:zones.(forall z:zone.(forall x:bits.(forall a:int. +((z=rt_zone(a,bits_size(x))) -> (rt_is_havoc(ma,m1,zs,m2) -> (zs_z_incl(z, +zs) -> rt_is_havoc(ma,m1,zs, +rt_store(m2,a,x)))))))))))) + +axiom havoc_invalid : (forall ma:memalloc.(forall m1:memory. +(forall m2:memory.(forall zs:zones.(forall z:zone.(forall x:bits. +(forall a:int.((z=rt_zone(a,bits_size(x))) -> (rt_is_havoc(ma,m1,zs, +m2) -> ((not rt_valid(ma,z)) -> rt_is_havoc(ma,m1,zs, +rt_store(m2,a,x)))))))))))) + +axiom same_bits_same_val : (forall b1:bits.(forall b2:bits. +(forall fmt:'a1 format. +((b1=b2) -> (rt_from_bits(b1,fmt)=rt_from_bits(b2,fmt)))))) + +axiom valid_vglob : (forall v:int.(rt_global(v) -> (forall ma:memalloc. +(forall ma':memalloc.rt_valid(ma, +rt_vzone(ma',v)))))) + + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/runtime_model.v frama-c-20111001+nitrogen+dfsg/src/wp/share/runtime_model.v --- frama-c-20110201+carbon+dfsg/src/wp/share/runtime_model.v 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/runtime_model.v 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,2515 @@ +( This file was originally generated by why. + It can be modified; only the generated parts will be overwritten. ) +Require Import Reals. Require Import wp. + +(Why logic) Definition bool_and : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_or : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_xor : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_not : bool -> bool. +Admitted. + +(Why axiom) Lemma bool_and_def : + (forall (a:bool), + (forall (b:bool), ((bool_and a b) = true <-> a = true /\ b = true))). +Admitted. + +(Why axiom) Lemma bool_or_def : + (forall (a:bool), + (forall (b:bool), ((bool_or a b) = true <-> a = true \/ b = true))). +Admitted. + +(Why axiom) Lemma bool_xor_def : + (forall (a:bool), (forall (b:bool), ((bool_xor a b) = true <-> ~(a = b)))). +Admitted. + +(Why axiom) Lemma bool_not_def : + (forall (a:bool), ((bool_not a) = true <-> a = false)). +Admitted. + +(Why logic) Definition ite : forall (A1:Set), bool -> A1 -> A1 -> A1. +Admitted. +Implicit Arguments ite. + +(Why axiom) Lemma ite_true : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), (if_then_else true x y) = x)). +Admitted. + +(Why axiom) Lemma ite_false : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), (if_then_else false x y) = y)). +Admitted. + +(Why logic) Definition lt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition le_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition gt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition ge_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition eq_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition neq_int_bool : Z -> Z -> bool. +Admitted. + +(Why axiom) Lemma lt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((lt_int_bool x y) = true <-> x < y))). +Admitted. + +(Why axiom) Lemma le_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((le_int_bool x y) = true <-> x <= y))). +Admitted. + +(Why axiom) Lemma gt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((gt_int_bool x y) = true <-> x > y))). +Admitted. + +(Why axiom) Lemma ge_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((ge_int_bool x y) = true <-> x >= y))). +Admitted. + +(Why axiom) Lemma eq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((eq_int_bool x y) = true <-> x = y))). +Admitted. + +(Why axiom) Lemma neq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((neq_int_bool x y) = true <-> x <> y))). +Admitted. + +(Why logic) Definition abs_int : Z -> Z. +Admitted. + +(Why axiom) Lemma abs_int_pos : + (forall (x:Z), (x >= 0 -> (abs_int x) = x)). +Admitted. + +(Why axiom) Lemma abs_int_neg : + (forall (x:Z), (x <= 0 -> (abs_int x) = (Zopp x))). +Admitted. + +(Why logic) Definition int_max : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_min : Z -> Z -> Z. +Admitted. + +(Why axiom) Lemma int_max_is_ge : + (forall (x:Z), (forall (y:Z), (int_max x y) >= x /\ (int_max x y) >= y)). +Admitted. + +(Why axiom) Lemma int_max_is_some : + (forall (x:Z), (forall (y:Z), (int_max x y) = x \/ (int_max x y) = y)). +Admitted. + +(Why axiom) Lemma int_min_is_le : + (forall (x:Z), (forall (y:Z), (int_min x y) <= x /\ (int_min x y) <= y)). +Admitted. + +(Why axiom) Lemma int_min_is_some : + (forall (x:Z), (forall (y:Z), (int_min x y) = x \/ (int_min x y) = y)). +Admitted. + +(Why logic) Definition lt_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition le_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition gt_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition ge_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition eq_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition neq_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition add_real : R -> R -> R. +Admitted. + +(Why logic) Definition sub_real : R -> R -> R. +Admitted. + +(Why logic) Definition mul_real : R -> R -> R. +Admitted. + +(Why logic) Definition div_real : R -> R -> R. +Admitted. + +(Why logic) Definition neg_real : R -> R. +Admitted. + +(Why logic) Definition real_of_int : Z -> R. +Admitted. + +(Why axiom) Lemma real_of_int_zero : (eq (IZR 0) (0)%R). +Admitted. + +(Why axiom) Lemma real_of_int_one : (eq (IZR 1) (1)%R). +Admitted. + +(Why axiom) Lemma real_of_int_add : + (forall (x:Z), (forall (y:Z), (eq (IZR (x + y)) (Rplus (IZR x) (IZR y))))). +Admitted. + +(Why axiom) Lemma real_of_int_sub : + (forall (x:Z), (forall (y:Z), (eq (IZR (x - y)) (Rminus (IZR x) (IZR y))))). +Admitted. + +(Why logic) Definition truncate_real_to_int : R -> Z. +Admitted. + +(Why axiom) Lemma truncate_down_pos : + (forall (x:R), + ((Rge x (0)%R) -> (Rle (IZR (truncate_real_to_int x)) x) /\ + (Rlt x (IZR ((truncate_real_to_int x) + 1))))). +Admitted. + +(Why axiom) Lemma truncate_up_neg : + (forall (x:R), + ((Rle x (0)%R) -> (Rlt (IZR ((truncate_real_to_int x) - 1)) x) /\ + (Rle x (IZR (truncate_real_to_int x))))). +Admitted. + +(Why logic) Definition floor_real_to_int : R -> Z. +Admitted. + +(Why logic) Definition ceil_real_to_int : R -> Z. +Admitted. + +(Why logic) Definition lt_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition le_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition gt_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition ge_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition eq_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition neq_real_bool : R -> R -> bool. +Admitted. + +(Why axiom) Lemma lt_real_bool_axiom : + (forall (x:R), (forall (y:R), ((lt_real_bool x y) = true <-> (Rlt x y)))). +Admitted. + +(Why axiom) Lemma le_real_bool_axiom : + (forall (x:R), (forall (y:R), ((le_real_bool x y) = true <-> (Rle x y)))). +Admitted. + +(Why axiom) Lemma gt_real_bool_axiom : + (forall (x:R), (forall (y:R), ((gt_real_bool x y) = true <-> (Rgt x y)))). +Admitted. + +(Why axiom) Lemma ge_real_bool_axiom : + (forall (x:R), (forall (y:R), ((ge_real_bool x y) = true <-> (Rge x y)))). +Admitted. + +(Why axiom) Lemma eq_real_bool_axiom : + (forall (x:R), (forall (y:R), ((eq_real_bool x y) = true <-> (eq x y)))). +Admitted. + +(Why axiom) Lemma neq_real_bool_axiom : + (forall (x:R), (forall (y:R), ((neq_real_bool x y) = true <-> ~(eq x y)))). +Admitted. + +(Why logic) Definition real_max : R -> R -> R. +Admitted. + +(Why logic) Definition real_min : R -> R -> R. +Admitted. + +(Why axiom) Lemma real_max_is_ge : + (forall (x:R), + (forall (y:R), (Rge (real_max x y) x) /\ (Rge (real_max x y) y))). +Admitted. + +(Why axiom) Lemma real_max_is_some : + (forall (x:R), + (forall (y:R), (eq (real_max x y) x) \/ (eq (real_max x y) y))). +Admitted. + +(Why axiom) Lemma real_min_is_le : + (forall (x:R), + (forall (y:R), (Rle (real_min x y) x) /\ (Rle (real_min x y) y))). +Admitted. + +(Why axiom) Lemma real_min_is_some : + (forall (x:R), + (forall (y:R), (eq (real_min x y) x) \/ (eq (real_min x y) y))). +Admitted. + +(Why function) Definition sqr_real (x:R) := (Rmult x x). + +(Why logic) Definition sqrt_real : R -> R. +Admitted. + +(Why axiom) Lemma sqrt_pos : + (forall (x:R), ((Rge x (0)%R) -> (Rge (sqrt x) (0)%R))). +Admitted. + +(Why axiom) Lemma sqrt_sqr : + (forall (x:R), ((Rge x (0)%R) -> (eq (sqr_real (sqrt x)) x))). +Admitted. + +(Why axiom) Lemma sqr_sqrt : + (forall (x:R), ((Rge x (0)%R) -> (eq (sqrt (Rmult x x)) x))). +Admitted. + +(Why logic) Definition pow_real : R -> R -> R. +Admitted. + +(Why logic) Definition abs_real : R -> R. +Admitted. + +(Why axiom) Lemma abs_real_pos : + (forall (x:R), ((Rge x (0)%R) -> (eq (Rabs x) x))). +Admitted. + +(Why axiom) Lemma abs_real_neg : + (forall (x:R), ((Rle x (0)%R) -> (eq (Rabs x) (Ropp x)))). +Admitted. + +(Why logic) Definition exp : R -> R. +Admitted. + +(Why logic) Definition log : R -> R. +Admitted. + +(Why logic) Definition log10 : R -> R. +Admitted. + +(Why axiom) Lemma log_exp : (forall (x:R), (eq (log (exp x)) x)). +Admitted. + +(Why axiom) Lemma exp_log : + (forall (x:R), ((Rgt x (0)%R) -> (eq (exp (log x)) x))). +Admitted. + +(Why logic) Definition cos : R -> R. +Admitted. + +(Why logic) Definition sin : R -> R. +Admitted. + +(Why logic) Definition tan : R -> R. +Admitted. + +(Why logic) Definition pi : R. +Admitted. + +(Why logic) Definition cosh : R -> R. +Admitted. + +(Why logic) Definition sinh : R -> R. +Admitted. + +(Why logic) Definition tanh : R -> R. +Admitted. + +(Why logic) Definition acos : R -> R. +Admitted. + +(Why logic) Definition asin : R -> R. +Admitted. + +(Why logic) Definition atan : R -> R. +Admitted. + +(Why logic) Definition atan2 : R -> R -> R. +Admitted. + +(Why logic) Definition hypot : R -> R -> R. +Admitted. + +(Why axiom) Lemma prod_pos : + (forall (x:R), + (forall (y:R), + (((Rgt x (0)%R) /\ (Rgt y (0)%R) -> (Rgt (Rmult x y) (0)%R))) /\ + (((Rlt x (0)%R) /\ (Rlt y (0)%R) -> (Rgt (Rmult x y) (0)%R))))). +Admitted. + +(Why axiom) Lemma abs_minus : + (forall (x:R), (eq (Rabs (Ropp x)) (Rabs x))). +Admitted. + +(Why type) Definition farray: Set ->Set. +Admitted. + +(Why logic) Definition access : forall (A1:Set), (array A1) -> Z -> A1. +Admitted. +Implicit Arguments access. + +(Why logic) Definition update : + forall (A1:Set), (array A1) -> Z -> A1 -> (array A1). +Admitted. +Implicit Arguments update. + +(Why axiom) Lemma access_update : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), (forall (v:A1), (access (update a i v) i) = v))). +Admitted. + +(Why axiom) Lemma access_update_neq : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (j:Z), + (forall (v:A1), (i <> j -> (access (update a i v) j) = (access a j)))))). +Admitted. + +(Why logic) Definition array_length : forall (A1:Set), (array A1) -> Z. +Admitted. +Implicit Arguments array_length. + +(Why predicate) Definition sorted_array (t:(array Z)) (i:Z) (j:Z) + := (forall (k1:Z), + (forall (k2:Z), + ((i <= k1 /\ k1 <= k2) /\ k2 <= j -> (access t k1) <= (access t k2)))). + +(Why predicate) Definition exchange (A302:Set) (a1:(array A302)) (a2:(array A302)) (i:Z) (j:Z) + := (array_length a1) = (array_length a2) /\ + (access a1 i) = (access a2 j) /\ (access a2 i) = (access a1 j) /\ + (forall (k:Z), (k <> i /\ k <> j -> (access a1 k) = (access a2 k))). +Implicit Arguments exchange. + +(Why logic) Definition permut : + forall (A1:Set), (array A1) -> (array A1) -> Z -> Z -> Prop. +Admitted. +Implicit Arguments permut. + +(Why axiom) Lemma permut_refl : + forall (A1:Set), + (forall (t:(array A1)), (forall (l:Z), (forall (u:Z), (permut t t l u)))). +Admitted. + +(Why axiom) Lemma permut_sym : + forall (A1:Set), + (forall (t1:(array A1)), + (forall (t2:(array A1)), + (forall (l:Z), (forall (u:Z), ((permut t1 t2 l u) -> (permut t2 t1 l u)))))). +Admitted. + +(Why axiom) Lemma permut_trans : + forall (A1:Set), + (forall (t1:(array A1)), + (forall (t2:(array A1)), + (forall (t3:(array A1)), + (forall (l:Z), + (forall (u:Z), + ((permut t1 t2 l u) -> ((permut t2 t3 l u) -> (permut t1 t3 l u)))))))). +Admitted. + +(Why axiom) Lemma permut_exchange : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + (forall (i:Z), + (forall (j:Z), + (l <= i /\ i <= u -> + (l <= j /\ j <= u -> ((exchange a1 a2 i j) -> (permut a1 a2 l u)))))))))). +Admitted. + +(Why axiom) Lemma exchange_upd : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (j:Z), + (exchange a (update (update a i (access a j)) j (access a i)) i j)))). +Admitted. + +(Why axiom) Lemma permut_weakening : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l1:Z), + (forall (r1:Z), + (forall (l2:Z), + (forall (r2:Z), + ((l1 <= l2 /\ l2 <= r2) /\ r2 <= r1 -> + ((permut a1 a2 l2 r2) -> (permut a1 a2 l1 r1))))))))). +Admitted. + +(Why axiom) Lemma permut_eq : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + (l <= u -> + ((permut a1 a2 l u) -> + (forall (i:Z), (i < l \/ u (access a2 i) = (access a1 i))))))))). +Admitted. + +(Why predicate) Definition permutation (A311:Set) (a1:(array A311)) (a2:(array A311)) + := (permut a1 a2 0 ((array_length a1) - 1)). +Implicit Arguments permutation. + +(Why axiom) Lemma array_length_update : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (v:A1), (array_length (update a i v)) = (array_length a)))). +Admitted. + +(Why axiom) Lemma permut_array_length : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + ((permut a1 a2 l u) -> (array_length a1) = (array_length a2)))))). +Admitted. + +(Why logic) Definition computer_div : Z -> Z -> Z. +Admitted. + +(Why logic) Definition computer_mod : Z -> Z -> Z. +Admitted. + +(Why logic) Definition math_div : Z -> Z -> Z. +Admitted. + +(Why logic) Definition math_mod : Z -> Z -> Z. +Admitted. + +(Why axiom) Lemma math_div_mod : + (forall (x:Z), + (forall (y:Z), (y <> 0 -> x = (y (math_div x y) + (math_mod x y))))). +Admitted. + +(Why axiom) Lemma math_mod_bound : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> 0 <= (math_mod x y) /\ (math_mod x y) < (abs_int y)))). +Admitted. + +(Why axiom) Lemma computer_div_mod : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> x = (y * (computer_div x y) + (computer_mod x y))))). +Admitted. + +(Why axiom) Lemma computer_div_bound : + (forall (x:Z), + (forall (y:Z), + (x >= 0 /\ y > 0 -> 0 <= (computer_div x y) /\ (computer_div x y) <= x))). +Admitted. + +(Why axiom) Lemma computer_mod_bound : + (forall (x:Z), + (forall (y:Z), (y <> 0 -> (abs_int (computer_mod x y)) < (abs_int y)))). +Admitted. + +(Why axiom) Lemma computer_mod_sign_pos : + (forall (x:Z), + (forall (y:Z), (x >= 0 /\ y <> 0 -> (computer_mod x y) >= 0))). +Admitted. + +(Why axiom) Lemma computer_mod_sign_neg : + (forall (x:Z), + (forall (y:Z), (x <= 0 /\ y <> 0 -> (computer_mod x y) <= 0))). +Admitted. + +(Why axiom) Lemma computer_rounds_toward_zero : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> (abs_int ((computer_div x y) * y)) <= (abs_int x)))). +Admitted. + +(Why logic) Definition dummy : Z -> Prop. +Admitted. + +(Why logic) Definition assigns : Z -> Prop. +Admitted. + +(Why axiom) Lemma positive_computer_div_div : + (forall (x:Z), + (forall (y:Z), (x > 0 -> (y > 0 -> (computer_div x y) = (math_div x y))))). +Admitted. + +(Why type) Definition set: Set ->Set. +Admitted. + +(Why logic) Definition empty : forall (A1:Set), (set A1). +Admitted. +Set Contextual Implicit. +Implicit Arguments empty. +Unset Contextual Implicit. + +(Why logic) Definition singleton : forall (A1:Set), A1 -> (set A1). +Admitted. +Implicit Arguments singleton. + +(Why logic) Definition range : Z -> Z -> (set Z). +Admitted. + +(Why logic) Definition union : + forall (A1:Set), (set A1) -> (set A1) -> (set A1). +Admitted. +Implicit Arguments union. + +(Why logic) Definition inter : + forall (A1:Set), (set A1) -> (set A1) -> (set A1). +Admitted. +Implicit Arguments inter. + +(Why logic) Definition plus_int : (set Z) -> (set Z) -> (set Z). +Admitted. + +(Why logic) Definition subset : + forall (A1:Set), (set A1) -> (set A1) -> Prop. +Admitted. +Implicit Arguments subset. + +(Why logic) Definition range_inf : Z -> (set Z). +Admitted. + +(Why logic) Definition range_sup : Z -> (set Z). +Admitted. + +(Why logic) Definition integers_set : (set Z). +Admitted. + +(Why logic) Definition equiv : + forall (A1:Set), (set A1) -> (set A1) -> Prop. +Admitted. +Implicit Arguments equiv. + +(Why logic) Definition member : forall (A1:Set), A1 -> (set A1) -> Prop. +Admitted. +Implicit Arguments member. + +(Why axiom) Lemma singleton_def : + forall (A1:Set), (forall (x:A1), (member x (singleton x))). +Admitted. + +(Why axiom) Lemma singleton_eq : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), ((member x (singleton y)) <-> x = y))). +Admitted. + +(Why axiom) Lemma union_member : + forall (A1:Set), + (forall (x:A1), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((member x (union s1 s2)) <-> (member x s1) \/ (member x s2))))). +Admitted. + +(Why axiom) Lemma union_of_empty : + forall (A1:Set), (forall (x:(set A1)), (union x (@empty A1)) = x). +Admitted. + +(Why axiom) Lemma inter_of_empty : + forall (A1:Set), (forall (x:(set A1)), (inter x (@empty A1)) = (@empty A1)). +Admitted. + +(Why axiom) Lemma union_comm : + forall (A1:Set), + (forall (x:(set A1)), (forall (y:(set A1)), (union x y) = (union y x))). +Admitted. + +(Why axiom) Lemma inter_comm : + forall (A1:Set), + (forall (x:(set A1)), (forall (y:(set A1)), (inter x y) = (inter y x))). +Admitted. + +(Why axiom) Lemma inter_member : + forall (A1:Set), + (forall (x:A1), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((member x (inter s1 s2)) <-> (member x s1) /\ (member x s2))))). +Admitted. + +(Why axiom) Lemma plus_int_member_1 : + (forall (sa:(set Z)), + (forall (sb:(set Z)), + (forall (a:Z), + (forall (b:Z), + ((member a sa) -> ((member b sb) -> (member (a + b) (plus_int sa sb)))))))). +Admitted. + +(Why axiom) Lemma plus_int_member_2 : + (forall (sa:(set Z)), + (forall (sb:(set Z)), + (forall (c:Z), + ((member c (plus_int sa sb)) -> + (exists a:Z, + (exists b:Z, (member a sa) /\ (member b sb) /\ c = (a + b))))))). +Admitted. + +(Why axiom) Lemma subset_empty : + forall (A1:Set), (forall (sa:(set A1)), (subset (@empty A1) sa)). +Admitted. + +(Why axiom) Lemma subset_sym : + forall (A1:Set), (forall (sa:(set A1)), (subset sa sa)). +Admitted. + +(Why axiom) Lemma subset_trans : + forall (A1:Set), + (forall (sa:(set A1)), + (forall (sb:(set A1)), + (forall (sc:(set A1)), + ((subset sa sb) -> ((subset sb sc) -> (subset sa sc)))))). +Admitted. + +(Why axiom) Lemma subset_def : + forall (A1:Set), + (forall (sa:(set A1)), + (forall (sb:(set A1)), + ((forall (a:A1), ((member a sa) -> (member a sb))) <-> (subset sa sb)))). +Admitted. + +(Why axiom) Lemma range_def : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), (i <= k /\ k <= j <-> (member k (range i j)))))). +Admitted. + +(Why axiom) Lemma range_def1 : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), (i <= k /\ k <= j -> (member k (range i j)))))). +Admitted. + +(Why axiom) Lemma range_def2 : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), ((member k (range i j)) -> i <= k /\ k <= j)))). +Admitted. + +(Why axiom) Lemma range_inf_def : + (forall (i:Z), (forall (k:Z), (i <= k <-> (member k (range_inf i))))). +Admitted. + +(Why axiom) Lemma range_sup_def : + (forall (j:Z), (forall (k:Z), (k <= j <-> (member k (range_sup j))))). +Admitted. + +(Why axiom) Lemma integers_set_def : + (forall (k:Z), (k >= 0 <-> (member k integers_set))). +Admitted. + +(Why axiom) Lemma equiv_def : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((forall (a:A1), ((member a s1) -> (member a s2))) /\ + (forall (b:A1), ((member b s2) -> (member b s1))) <-> (equiv s1 s2)))). +Admitted. + +(Why axiom) Lemma equiv_refl : + forall (A1:Set), (forall (s:(set A1)), (equiv s s)). +Admitted. + +(Why axiom) Lemma equiv_sym : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), ((equiv s1 s2) -> (equiv s2 s1)))). +Admitted. + +(Why axiom) Lemma equiv_trans : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + (forall (s3:(set A1)), + ((equiv s1 s2) -> ((equiv s2 s3) -> (equiv s1 s3)))))). +Admitted. + +(Why logic) Definition as_uint8 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint8 (x:Z) := 0 <= x /\ x < 256. + +(Why axiom) Lemma as_uint8_def : (forall (x:Z), (is_uint8 (as_uint8 x))). +Admitted. + +(Why axiom) Lemma as_uint8_involve : + (forall (x:Z), (as_uint8 (as_uint8 x)) = (as_uint8 x)). +Admitted. + +(Why axiom) Lemma is_as_uint8 : + (forall (x:Z), ((is_uint8 x) -> (as_uint8 x) = x)). +Admitted. + +(Why logic) Definition as_sint8 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint8 (x:Z) := (-128) <= x /\ x < 128. + +(Why axiom) Lemma as_sint8_def : (forall (x:Z), (is_sint8 (as_sint8 x))). +Admitted. + +(Why axiom) Lemma as_sint8_involve : + (forall (x:Z), (as_sint8 (as_sint8 x)) = (as_sint8 x)). +Admitted. + +(Why axiom) Lemma is_as_sint8 : + (forall (x:Z), ((is_sint8 x) -> (as_sint8 x) = x)). +Admitted. + +(Why logic) Definition as_uint16 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint16 (x:Z) := 0 <= x /\ x < 65536. + +(Why axiom) Lemma as_uint16_def : + (forall (x:Z), (is_uint16 (as_uint16 x))). +Admitted. + +(Why axiom) Lemma as_uint16_involve : + (forall (x:Z), (as_uint16 (as_uint16 x)) = (as_uint16 x)). +Admitted. + +(Why axiom) Lemma is_as_uint16 : + (forall (x:Z), ((is_uint16 x) -> (as_uint16 x) = x)). +Admitted. + +(Why logic) Definition as_sint16 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint16 (x:Z) := (-32768) <= x /\ x < 32768. + +(Why axiom) Lemma as_sint16_def : + (forall (x:Z), (is_sint16 (as_sint16 x))). +Admitted. + +(Why axiom) Lemma as_sint16_involve : + (forall (x:Z), (as_sint16 (as_sint16 x)) = (as_sint16 x)). +Admitted. + +(Why axiom) Lemma is_as_sint16 : + (forall (x:Z), ((is_sint16 x) -> (as_sint16 x) = x)). +Admitted. + +(Why logic) Definition as_uint32 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint32 (x:Z) := 0 <= x /\ x < 4294967296. + +(Why axiom) Lemma as_uint32_def : + (forall (x:Z), (is_uint32 (as_uint32 x))). +Admitted. + +(Why axiom) Lemma as_uint32_involve : + (forall (x:Z), (as_uint32 (as_uint32 x)) = (as_uint32 x)). +Admitted. + +(Why axiom) Lemma is_as_uint32 : + (forall (x:Z), ((is_uint32 x) -> (as_uint32 x) = x)). +Admitted. + +(Why logic) Definition as_sint32 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint32 (x:Z) + := (-2147483648) <= x /\ x < 2147483648. + +(Why axiom) Lemma as_sint32_def : + (forall (x:Z), (is_sint32 (as_sint32 x))). +Admitted. + +(Why axiom) Lemma as_sint32_involve : + (forall (x:Z), (as_sint32 (as_sint32 x)) = (as_sint32 x)). +Admitted. + +(Why axiom) Lemma is_as_sint32 : + (forall (x:Z), ((is_sint32 x) -> (as_sint32 x) = x)). +Admitted. + +(Why logic) Definition as_uint64 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint64 (x:Z) + := 0 <= x /\ x < 18446744073709551616. + +(Why axiom) Lemma as_uint64_def : + (forall (x:Z), (is_uint64 (as_uint64 x))). +Admitted. + +(Why axiom) Lemma as_uint64_involve : + (forall (x:Z), (as_uint64 (as_uint64 x)) = (as_uint64 x)). +Admitted. + +(Why axiom) Lemma is_as_uint64 : + (forall (x:Z), ((is_uint64 x) -> (as_uint64 x) = x)). +Admitted. + +(Why logic) Definition as_sint64 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint64 (x:Z) + := (-9223372036854775808) <= x /\ x < 9223372036854775808. + +(Why axiom) Lemma as_sint64_def : + (forall (x:Z), (is_sint64 (as_sint64 x))). +Admitted. + +(Why axiom) Lemma as_sint64_involve : + (forall (x:Z), (as_sint64 (as_sint64 x)) = (as_sint64 x)). +Admitted. + +(Why axiom) Lemma is_as_sint64 : + (forall (x:Z), ((is_sint64 x) -> (as_sint64 x) = x)). +Admitted. + +(Why logic) Definition as_float16 : R -> R. +Admitted. + +(Why logic) Definition is_float16 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float16_def : + (forall (x:R), (is_float16 (as_float16 x))). +Admitted. + +(Why axiom) Lemma as_float16_involve : + (forall (x:R), (eq (as_float16 (as_float16 x)) (as_float16 x))). +Admitted. + +(Why axiom) Lemma is_as_float16 : + (forall (x:R), ((is_float16 x) -> (eq (as_float16 x) x))). +Admitted. + +(Why logic) Definition as_float32 : R -> R. +Admitted. + +(Why logic) Definition is_float32 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float32_def : + (forall (x:R), (is_float32 (as_float32 x))). +Admitted. + +(Why axiom) Lemma as_float32_involve : + (forall (x:R), (eq (as_float32 (as_float32 x)) (as_float32 x))). +Admitted. + +(Why axiom) Lemma is_as_float32 : + (forall (x:R), ((is_float32 x) -> (eq (as_float32 x) x))). +Admitted. + +(Why logic) Definition as_float64 : R -> R. +Admitted. + +(Why logic) Definition is_float64 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float64_def : + (forall (x:R), (is_float64 (as_float64 x))). +Admitted. + +(Why axiom) Lemma as_float64_involve : + (forall (x:R), (eq (as_float64 (as_float64 x)) (as_float64 x))). +Admitted. + +(Why axiom) Lemma is_as_float64 : + (forall (x:R), ((is_float64 x) -> (eq (as_float64 x) x))). +Admitted. + +(Why logic) Definition as_float128 : R -> R. +Admitted. + +(Why logic) Definition is_float128 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float128_def : + (forall (x:R), (is_float128 (as_float128 x))). +Admitted. + +(Why axiom) Lemma as_float128_involve : + (forall (x:R), (eq (as_float128 (as_float128 x)) (as_float128 x))). +Admitted. + +(Why axiom) Lemma is_as_float128 : + (forall (x:R), ((is_float128 x) -> (eq (as_float128 x) x))). +Admitted. + +(Why type) Definition data: Set. +Admitted. + +(Why logic) Definition data_of_uint8 : Z -> data. +Admitted. + +(Why logic) Definition uint8_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint8_of_data : + (forall (d:data), (is_uint8 (uint8_of_data d))). +Admitted. + +(Why axiom) Lemma uint8ofdata_dataofuint8 : + (forall (x:Z), ((is_uint8 x) -> (uint8_of_data (data_of_uint8 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint8 : Z -> data. +Admitted. + +(Why logic) Definition sint8_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint8_of_data : + (forall (d:data), (is_sint8 (sint8_of_data d))). +Admitted. + +(Why axiom) Lemma sint8ofdata_dataofsint8 : + (forall (x:Z), ((is_sint8 x) -> (sint8_of_data (data_of_sint8 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint16 : Z -> data. +Admitted. + +(Why logic) Definition uint16_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint16_of_data : + (forall (d:data), (is_uint16 (uint16_of_data d))). +Admitted. + +(Why axiom) Lemma uint16ofdata_dataofuint16 : + (forall (x:Z), ((is_uint16 x) -> (uint16_of_data (data_of_uint16 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint16 : Z -> data. +Admitted. + +(Why logic) Definition sint16_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint16_of_data : + (forall (d:data), (is_sint16 (sint16_of_data d))). +Admitted. + +(Why axiom) Lemma sint16ofdata_dataofsint16 : + (forall (x:Z), ((is_sint16 x) -> (sint16_of_data (data_of_sint16 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint32 : Z -> data. +Admitted. + +(Why logic) Definition uint32_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint32_of_data : + (forall (d:data), (is_uint32 (uint32_of_data d))). +Admitted. + +(Why axiom) Lemma uint32ofdata_dataofuint32 : + (forall (x:Z), ((is_uint32 x) -> (uint32_of_data (data_of_uint32 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint32 : Z -> data. +Admitted. + +(Why logic) Definition sint32_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint32_of_data : + (forall (d:data), (is_sint32 (sint32_of_data d))). +Admitted. + +(Why axiom) Lemma sint32ofdata_dataofsint32 : + (forall (x:Z), ((is_sint32 x) -> (sint32_of_data (data_of_sint32 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint64 : Z -> data. +Admitted. + +(Why logic) Definition uint64_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint64_of_data : + (forall (d:data), (is_uint64 (uint64_of_data d))). +Admitted. + +(Why axiom) Lemma uint64ofdata_dataofuint64 : + (forall (x:Z), ((is_uint64 x) -> (uint64_of_data (data_of_uint64 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint64 : Z -> data. +Admitted. + +(Why logic) Definition sint64_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint64_of_data : + (forall (d:data), (is_sint64 (sint64_of_data d))). +Admitted. + +(Why axiom) Lemma sint64ofdata_dataofsint64 : + (forall (x:Z), ((is_sint64 x) -> (sint64_of_data (data_of_sint64 x)) = x)). +Admitted. + +(Why logic) Definition data_of_float16 : R -> data. +Admitted. + +(Why logic) Definition float16_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float16_of_data : + (forall (d:data), (is_float16 (float16_of_data d))). +Admitted. + +(Why axiom) Lemma float16ofdata_dataoffloat16 : + (forall (x:R), + ((is_float16 x) -> (eq (float16_of_data (data_of_float16 x)) x))). +Admitted. + +(Why logic) Definition data_of_float32 : R -> data. +Admitted. + +(Why logic) Definition float32_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float32_of_data : + (forall (d:data), (is_float32 (float32_of_data d))). +Admitted. + +(Why axiom) Lemma float32ofdata_dataoffloat32 : + (forall (x:R), + ((is_float32 x) -> (eq (float32_of_data (data_of_float32 x)) x))). +Admitted. + +(Why logic) Definition data_of_float64 : R -> data. +Admitted. + +(Why logic) Definition float64_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float64_of_data : + (forall (d:data), (is_float64 (float64_of_data d))). +Admitted. + +(Why axiom) Lemma float64ofdata_dataoffloat64 : + (forall (x:R), + ((is_float64 x) -> (eq (float64_of_data (data_of_float64 x)) x))). +Admitted. + +(Why logic) Definition data_of_float128 : R -> data. +Admitted. + +(Why logic) Definition float128_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float128_of_data : + (forall (d:data), (is_float128 (float128_of_data d))). +Admitted. + +(Why axiom) Lemma float128ofdata_dataoffloat128 : + (forall (x:R), + ((is_float128 x) -> (eq (float128_of_data (data_of_float128 x)) x))). +Admitted. + +(Why logic) Definition set_range_index : + forall (A1:Set), (array A1) -> (set Z) -> Z -> (array A1). +Admitted. +Implicit Arguments set_range_index. + +(Why axiom) Lemma set_range_def : + forall (A1:Set), + (forall (t:(array A1)), + (forall (rg:(set Z)), + (forall (k:Z), + (forall (i:Z), + (~(member i rg) -> (access (set_range_index t rg k) i) = (access t i)))))). +Admitted. + +(Why logic) Definition bnot : Z -> Z. +Admitted. + +(Why logic) Definition band : Z -> Z -> Z. +Admitted. + +(Why logic) Definition bor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition bxor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition lshift : Z -> Z -> Z. +Admitted. + +(Why logic) Definition rshift : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_not : Z -> Z. +Admitted. + +(Why logic) Definition int_and : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_or : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_xor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_lsh : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_rshs : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_rshu : Z -> Z -> Z. +Admitted. + +(Why type) Definition format: Set ->Set. +Admitted. + +(Why logic) Definition format_size : forall (A1:Set), (format A1) -> Z. +Admitted. +Implicit Arguments format_size. + +(Why logic) Definition is_in_format : + forall (A1:Set), (format A1) -> A1 -> Prop. +Admitted. +Implicit Arguments is_in_format. + +(Why logic) Definition signed_format : (format Z) -> bool. +Admitted. + +(Why logic) Definition uint8_format : (format Z). +Admitted. + +(Why axiom) Lemma uint8_format_size : (format_size uint8_format) = 8. +Admitted. + +(Why axiom) Lemma uint8_format_sign : (signed_format uint8_format) = false. +Admitted. + +(Why logic) Definition sint8_format : (format Z). +Admitted. + +(Why axiom) Lemma sint8_format_size : (format_size sint8_format) = 8. +Admitted. + +(Why axiom) Lemma sint8_format_sign : (signed_format sint8_format) = true. +Admitted. + +(Why logic) Definition uint16_format : (format Z). +Admitted. + +(Why axiom) Lemma uint16_format_size : (format_size uint16_format) = 16. +Admitted. + +(Why axiom) Lemma uint16_format_sign : + (signed_format uint16_format) = false. +Admitted. + +(Why logic) Definition sint16_format : (format Z). +Admitted. + +(Why axiom) Lemma sint16_format_size : (format_size sint16_format) = 16. +Admitted. + +(Why axiom) Lemma sint16_format_sign : + (signed_format sint16_format) = true. +Admitted. + +(Why logic) Definition uint32_format : (format Z). +Admitted. + +(Why axiom) Lemma uint32_format_size : (format_size uint32_format) = 32. +Admitted. + +(Why axiom) Lemma uint32_format_sign : + (signed_format uint32_format) = false. +Admitted. + +(Why logic) Definition sint32_format : (format Z). +Admitted. + +(Why axiom) Lemma sint32_format_size : (format_size sint32_format) = 32. +Admitted. + +(Why axiom) Lemma sint32_format_sign : + (signed_format sint32_format) = true. +Admitted. + +(Why logic) Definition uint64_format : (format Z). +Admitted. + +(Why axiom) Lemma uint64_format_size : (format_size uint64_format) = 64. +Admitted. + +(Why axiom) Lemma uint64_format_sign : + (signed_format uint64_format) = false. +Admitted. + +(Why logic) Definition sint64_format : (format Z). +Admitted. + +(Why axiom) Lemma sint64_format_size : (format_size sint64_format) = 64. +Admitted. + +(Why axiom) Lemma sint64_format_sign : + (signed_format sint64_format) = true. +Admitted. + +(Why axiom) Lemma is_in_format_sint8 : + (forall (x:Z), ((is_in_format sint8_format x) <-> (-128) <= x /\ x < 128)). +Admitted. + +(Why axiom) Lemma is_in_format_uint8 : + (forall (x:Z), ((is_in_format uint8_format x) <-> 0 <= x /\ x < 256)). +Admitted. + +(Why axiom) Lemma is_in_format_sint16 : + (forall (x:Z), + ((is_in_format sint16_format x) <-> (-32768) <= x /\ x < 32768)). +Admitted. + +(Why axiom) Lemma is_in_format_uint16 : + (forall (x:Z), ((is_in_format uint16_format x) <-> 0 <= x /\ x < 65536)). +Admitted. + +(Why axiom) Lemma is_in_format_sint32 : + (forall (x:Z), + ((is_in_format sint32_format x) <-> (-2147483648) <= x /\ x < 2147483648)). +Admitted. + +(Why axiom) Lemma is_in_format_uint32 : + (forall (x:Z), + ((is_in_format uint32_format x) <-> 0 <= x /\ x < 4294967296)). +Admitted. + +(Why axiom) Lemma is_in_format_sint64 : + (forall (x:Z), + ((is_in_format sint64_format x) <-> (-9223372036854775808) <= x /\ x < + 9223372036854775808)). +Admitted. + +(Why axiom) Lemma is_in_format_uint64 : + (forall (x:Z), + ((is_in_format uint64_format x) <-> 0 <= x /\ x < 18446744073709551616)). +Admitted. + +(Why logic) Definition float16_format : (format R). +Admitted. + +(Why axiom) Lemma float16_format_size : (format_size float16_format) = 16. +Admitted. + +(Why logic) Definition float32_format : (format R). +Admitted. + +(Why axiom) Lemma float32_format_size : (format_size float32_format) = 32. +Admitted. + +(Why logic) Definition float64_format : (format R). +Admitted. + +(Why axiom) Lemma float64_format_size : (format_size float64_format) = 64. +Admitted. + +(Why logic) Definition float96_format : (format R). +Admitted. + +(Why axiom) Lemma float96_format_size : (format_size float96_format) = 96. +Admitted. + +(Why logic) Definition float128_format : (format R). +Admitted. + +(Why axiom) Lemma float128_format_size : + (format_size float128_format) = 128. +Admitted. + +(Why logic) Definition encode : forall (A1:Set), (format A1) -> A1 -> data. +Admitted. +Implicit Arguments encode. + +(Why logic) Definition decode : forall (A1:Set), (format A1) -> data -> A1. +Admitted. +Implicit Arguments decode. + +(Why axiom) Lemma encode_decode : + forall (A1:Set), + (forall (f:(format A1)), (forall (d:data), (encode f (decode f d)) = d)). +Admitted. + +(Why axiom) Lemma decode_encode : + forall (A1:Set), + (forall (f:(format A1)), (forall (x:A1), (decode f (encode f x)) = x)). +Admitted. + +(Why axiom) Lemma decode_inj : + forall (A1:Set), + (forall (d:data), + (forall (d':data), + (forall (f:(format A1)), (~((decode f d) = (decode f d')) <-> ~(d = d'))))). +Admitted. + +(Why axiom) Lemma decode_eq : + forall (A1:Set), + (forall (d:data), + (forall (d':data), + (forall (f:(format A1)), ((decode f d) = (decode f d') <-> d = d')))). +Admitted. + +(Why logic) Definition int_format : (format Z). +Admitted. + +(Why logic) Definition real_format : (format R). +Admitted. + +(Why logic) Definition as_int : (format Z) -> Z -> Z. +Admitted. + +(Why axiom) Lemma simpl_as_int : + (forall (f:(format Z)), + (forall (x:Z), ((is_in_format f x) -> (as_int f x) = x))). +Admitted. + +(Why axiom) Lemma as_int_def : + (forall (f:(format Z)), (forall (x:Z), (is_in_format f (as_int f x)))). +Admitted. + +(Why axiom) Lemma involve_as_int : + (forall (f:(format Z)), + (forall (x:Z), (as_int f (as_int f x)) = (as_int f x))). +Admitted. + +(Why logic) Definition as_float : (format R) -> R -> R. +Admitted. + +(Why axiom) Lemma simpl_as_float : + (forall (f:(format R)), + (forall (x:R), ((is_in_format f x) -> (eq (as_float f x) x)))). +Admitted. + +(Why axiom) Lemma as_float_def : + (forall (f:(format R)), (forall (x:R), (is_in_format f (as_float f x)))). +Admitted. + +(Why axiom) Lemma involve_as_float : + (forall (f:(format R)), + (forall (x:R), (eq (as_float f (as_float f x)) (as_float f x)))). +Admitted. + +(Why type) Definition zone: Set. +Admitted. + +(Why logic) Definition rt_zone : Z -> Z -> zone. +Admitted. + +(Why logic) Definition z_addr : zone -> Z. +Admitted. + +(Why logic) Definition z_size : zone -> Z. +Admitted. + +(Why axiom) Lemma addr_zone : + (forall (a:Z), (forall (sz:Z), (z_addr (rt_zone a sz)) = a)). +Admitted. + +(Why axiom) Lemma size_zone : + (forall (a:Z), (forall (sz:Z), (0 <= sz -> (z_size (rt_zone a sz)) = sz))). +Admitted. + +(Why axiom) Lemma rt_zone_inj : + (forall (a1:Z), + (forall (a2:Z), + (forall (sz1:Z), + (forall (sz2:Z), + ((rt_zone a1 sz1) = (rt_zone a2 sz2) <-> a1 = a2 /\ sz1 = sz2))))). +Admitted. + +(Why predicate) Definition rt_disj (z1:zone) (z2:zone) + := ((z_addr z1) + (z_size z1)) <= (z_addr z2) \/ + ((z_addr z2) + (z_size z2)) <= (z_addr z1). + +(Why predicate) Definition rt_incl (z1:zone) (z2:zone) + := (z_addr z2) <= (z_addr z1) /\ ((z_addr z1) + (z_size z1)) <= + ((z_addr z2) + (z_size z2)). + +(Why predicate) Definition addr_in_zone (a:Z) (z:zone) + := (z_addr z) <= a /\ a < ((z_addr z) + (z_size z)). + +(Why function) Definition rt_shift (addr:Z) (offset:Z) := (addr + offset). + +(Why logic) Definition rt_foffset : Z -> Z. +Admitted. + +(Why logic) Definition rt_fsize : Z -> Z. +Admitted. + +(Why logic) Definition rt_fformat : Z -> (format Z). +Admitted. + +(Why type) Definition zones: Set. +Admitted. + +(Why logic) Definition zs_empty : zones. +Admitted. + +(Why logic) Definition zs_singleton : zone -> zones. +Admitted. + +(Why logic) Definition zs_union : zones -> zones -> zones. +Admitted. + +(Why logic) Definition zs_incl : zones -> zones -> Prop. +Admitted. + +(Why logic) Definition zs_disj : zones -> zones -> Prop. +Admitted. + +(Why predicate) Definition zs_z_incl (z:zone) (zs:zones) + := (zs_incl (zs_singleton z) zs). + +(Why predicate) Definition zs_z_disj (z:zone) (zs:zones) + := (zs_disj (zs_singleton z) zs). + +(Why axiom) Lemma zs_empty_incl : + (forall (zs:zones), (zs_incl zs_empty zs)). +Admitted. + +(Why axiom) Lemma zs_z_not_incl_empty : + (forall (z:zone), ~(zs_incl (zs_singleton z) zs_empty)). +Admitted. + +(Why axiom) Lemma zs_incl_singleton : + (forall (z1:zone), + (forall (z2:zone), + ((rt_incl z1 z2) <-> (zs_incl (zs_singleton z1) (zs_singleton z2))))). +Admitted. + +(Why axiom) Lemma zs_incl_union_1 : + (forall (z:zones), + (forall (z1:zones), + (forall (z2:zones), ((zs_incl z z1) -> (zs_incl z (zs_union z1 z2)))))). +Admitted. + +(Why axiom) Lemma zs_incl_union_2 : + (forall (z:zones), + (forall (z1:zones), + (forall (z2:zones), ((zs_incl z z2) -> (zs_incl z (zs_union z1 z2)))))). +Admitted. + +(Why axiom) Lemma zs_incl_union_3 : + (forall (z:zones), + (forall (z1:zones), + (forall (z2:zones), + ((zs_incl z1 z) -> ((zs_incl z2 z) -> (zs_incl (zs_union z1 z2) z)))))). +Admitted. + +(Why axiom) Lemma zs_disj_singleton : + (forall (z1:zone), + (forall (z2:zone), + ((rt_disj z1 z2) <-> (zs_disj (zs_singleton z1) (zs_singleton z2))))). +Admitted. + +(Why axiom) Lemma zs_incl_disj : + (forall (z:zones), + (forall (zi:zones), + (forall (zd:zones), + ((zs_incl zi z) -> ((zs_disj zd z) -> (zs_disj zi zd)))))). +Admitted. + +(Why type) Definition bits: Set. +Admitted. + +(Why logic) Definition bits_size : bits -> Z. +Admitted. + +(Why axiom) Lemma bits_size_pos : (forall (b:bits), (bits_size b) >= 0). +Admitted. + +(Why logic) Definition nth_bit : bits -> Z -> bool. +Admitted. + +(Why axiom) Lemma eq_bits : + (forall (b1:bits), + (forall (b2:bits), + (forall (sz:Z), + ((bits_size b1) = sz -> + ((bits_size b2) = sz -> + ((forall (i:Z), (0 <= i /\ i < sz -> (nth_bit b1 i) = (nth_bit b2 i))) <-> + b1 = b2)))))). +Admitted. + +(Why predicate) Definition zero_bits (b:bits) + := (forall (i:Z), (0 <= i /\ i < (bits_size b) -> (nth_bit b i) = false)). + +(Why logic) Definition bits_part : bits -> Z -> Z -> bits. +Admitted. + +(Why axiom) Lemma bits_part_size : + (forall (b:bits), + (forall (off:Z), + (forall (sz:Z), + (0 <= off -> + ((off + sz) <= (bits_size b) -> (bits_size (bits_part b off sz)) = sz))))). +Admitted. + +(Why axiom) Lemma nth_bits_part : + (forall (b:bits), + (forall (off:Z), + (forall (i:Z), + (forall (sz:Z), + (0 <= i /\ i < sz -> + (0 <= off -> + ((off + sz) <= (bits_size b) -> + (nth_bit (bits_part b off sz) i) = (nth_bit b (off + i))))))))). +Admitted. + +(Why logic) Definition bits_concat : bits -> bits -> bits. +Admitted. + +(Why axiom) Lemma bits_concat_size : + (forall (b1:bits), + (forall (b2:bits), (bits_size (bits_concat b1 b2)) = + ((bits_size b1) + (bits_size b2)))). +Admitted. + +(Why axiom) Lemma nth_bits_concat_l : + (forall (b1:bits), + (forall (b2:bits), + (forall (i:Z), + (0 <= i /\ i < (bits_size b1) -> + (nth_bit (bits_concat b1 b2) i) = (nth_bit b1 i))))). +Admitted. + +(Why axiom) Lemma nth_bits_concat_r : + (forall (b1:bits), + (forall (b2:bits), + (forall (i:Z), + (forall (sz1:Z), + (forall (sz2:Z), + (sz1 = (bits_size b1) -> + (sz2 = (bits_size b2) -> + (sz1 <= i /\ i < (sz1 + sz2) -> + (nth_bit (bits_concat b1 b2) i) = (nth_bit b2 (i - sz1)))))))))). +Admitted. + +(Why logic) Definition wr_bits_part : bits -> Z -> bits -> bits. +Admitted. + +(Why axiom) Lemma wr_bits_part_size : + (forall (b:bits), + (forall (bw:bits), + (forall (o:Z), (bits_size (wr_bits_part b o bw)) = (bits_size b)))). +Admitted. + +(Why axiom) Lemma nth_wr_bits_part_1 : + (forall (b:bits), + (forall (b':bits), + (forall (off:Z), + (forall (i:Z), + (0 <= i /\ i < off -> + (nth_bit (wr_bits_part b off b') i) = (nth_bit b i)))))). +Admitted. + +(Why axiom) Lemma nth_wr_bits_part_2 : + (forall (b:bits), + (forall (b':bits), + (forall (off:Z), + (forall (i:Z), + ((0 <= off /\ off <= i) /\ i < (off + (bits_size b')) -> + (nth_bit (wr_bits_part b off b') i) = (nth_bit b' (i - off))))))). +Admitted. + +(Why axiom) Lemma nth_wr_bits_part_3 : + (forall (b:bits), + (forall (b':bits), + (forall (off:Z), + (forall (i:Z), + ((0 <= (off + (bits_size b')) /\ (off + (bits_size b')) <= i) /\ i < + (bits_size b) -> (nth_bit (wr_bits_part b off b') i) = (nth_bit b i)))))). +Admitted. + +(Why logic) Definition rt_from_bits : + forall (A1:Set), bits -> (format A1) -> A1. +Admitted. +Implicit Arguments rt_from_bits. + +(Why axiom) Lemma rt_from_bits_format : + forall (A1:Set), + (forall (b:bits), + (forall (fmt:(format A1)), + ((bits_size b) = (format_size fmt) -> + (is_in_format fmt (rt_from_bits b fmt))))). +Admitted. + +(Why logic) Definition rt_to_bits : + forall (A1:Set), (format A1) -> A1 -> bits. +Admitted. +Implicit Arguments rt_to_bits. + +(Why axiom) Lemma rt_to_bits_size : + forall (A1:Set), + (forall (fmt:(format A1)), + (forall (x:A1), (bits_size (rt_to_bits fmt x)) = (format_size fmt))). +Admitted. + +(Why axiom) Lemma rt_to_bits_from_bits : + forall (A1:Set), + (forall (fmt:(format A1)), + (forall (b:bits), + ((bits_size b) = (format_size fmt) -> + (rt_to_bits fmt (rt_from_bits b fmt)) = b))). +Admitted. + +(Why axiom) Lemma rt_from_bits_to_bits : + forall (A1:Set), + (forall (fmt:(format A1)), + (forall (v:A1), + ((is_in_format fmt v) -> (rt_from_bits (rt_to_bits fmt v) fmt) = v))). +Admitted. + +(Why axiom) Lemma same_int_val_same_bits : + (forall (b1:bits), + (forall (b2:bits), + (forall (fmt:(format Z)), + ((bits_size b1) = (format_size fmt) -> + ((bits_size b2) = (format_size fmt) -> + ((rt_from_bits b1 fmt) = (rt_from_bits b2 fmt) -> b1 = b2)))))). +Admitted. + +(Why axiom) Lemma rt_to_bits_zero : + (forall (fmt:(format Z)), + (forall (b:bits), (b = (rt_to_bits fmt 0) -> (zero_bits b)))). +Admitted. + +(Why axiom) Lemma rt_from_bits_zero : + (forall (b:bits), + (forall (fmt:(format Z)), ((zero_bits b) -> (rt_from_bits b fmt) = 0))). +Admitted. + +(Why logic) Definition mbyte_to_bbits : bits -> (array bool). +Admitted. + +(Why axiom) Lemma mbyte_to_bbits_def : + (forall (b:bits), + ((bits_size b) = 8 -> + (forall (i:Z), + (0 <= i /\ i < 8 -> (access (mbyte_to_bbits b) i) = (nth_bit b (7 - i)))))). +Admitted. + +(Why logic) Definition nth_mbyte : Z -> bits -> bits. +Admitted. + +(Why axiom) Lemma nth_mbyte_size : + (forall (b:bits), (forall (k:Z), (bits_size (nth_mbyte k b)) = 8)). +Admitted. + +(Why axiom) Lemma nth_byte_def : + (forall (b:bits), + (forall (k:Z), + (0 <= (8 * (k + 1)) /\ (8 * (k + 1)) <= (bits_size b) -> + (forall (i:Z), + (0 <= i /\ i < 8 -> + (nth_bit (nth_mbyte k b) i) = (nth_bit b (8 * k + i))))))). +Admitted. + +(Why function) Definition nth_byte (k:Z) (b:bits) + := (mbyte_to_bbits (nth_mbyte k b)). + +(Why logic) Definition little_endian : Prop. +Admitted. + +(Why logic) Definition concat_bytes : + (array bool) -> (array bool) -> (array bool). +Admitted. + +(Why axiom) Lemma concat_bytes_left : + (forall (w:(array bool)), + (forall (b:(array bool)), + (forall (i:Z), + (8 <= i -> (access (concat_bytes w b) i) = (access w (i - 8)))))). +Admitted. + +(Why axiom) Lemma concat_bytes_right : + (forall (w:(array bool)), + (forall (b:(array bool)), + (forall (i:Z), + (0 <= i /\ i < 8 -> (access (concat_bytes w b) i) = (access b i))))). +Admitted. + +(Why logic) Definition uint_of_bits : Z -> (array bool) -> Z. +Admitted. + +(Why logic) Definition sint_of_bits : Z -> (array bool) -> Z. +Admitted. + +(Why function) Definition cint_of_bits (fmt:(format Z)) (b:(array bool)) + := (if_then_else (signed_format fmt) + (sint_of_bits ((format_size fmt) - 1) b) + (uint_of_bits ((format_size fmt) - 1) b)). + +(Why logic) Definition bits_of_sint : Z -> Z -> (array bool). +Admitted. + +(Why logic) Definition bits_of_uint : Z -> Z -> (array bool). +Admitted. + +(Why function) Definition bits_of_cint (fmt:(format Z)) (x:Z) + := (if_then_else (signed_format fmt) + (bits_of_sint ((format_size fmt) - 1) x) + (bits_of_uint ((format_size fmt) - 1) x)). + +(Why logic) Definition mbits_to_bbits : bits -> (array bool). +Admitted. + +(Why axiom) Lemma mb8_to_bbits : + (forall (b:bits), + ((bits_size b) = 8 -> (mbits_to_bbits b) = (nth_byte 0 b))). +Admitted. + +(Why axiom) Lemma little_mb16_to_bbits : + (forall (b:bits), + ((bits_size b) = 16 -> + (little_endian -> + (mbits_to_bbits b) = (concat_bytes (nth_byte 1 b) (nth_byte 0 b))))). +Admitted. + +(Why axiom) Lemma big_mb16_to_bbits : + (forall (b:bits), + ((bits_size b) = 16 -> + (~little_endian -> + (mbits_to_bbits b) = (concat_bytes (nth_byte 0 b) (nth_byte 1 b))))). +Admitted. + +(Why axiom) Lemma little_mb32_to_bbits : + (forall (b:bits), + ((bits_size b) = 32 -> + (little_endian -> + (mbits_to_bbits b) = + (concat_bytes + (concat_bytes + (concat_bytes (nth_byte 3 b) (nth_byte 2 b)) (nth_byte 1 b)) ( + nth_byte 0 b))))). +Admitted. + +(Why axiom) Lemma big_mb32_to_bbits : + (forall (b:bits), + ((bits_size b) = 32 -> + (~little_endian -> + (mbits_to_bbits b) = + (concat_bytes + (concat_bytes + (concat_bytes (nth_byte 0 b) (nth_byte 1 b)) (nth_byte 2 b)) ( + nth_byte 3 b))))). +Admitted. + +(Why axiom) Lemma rt_int_from_bits : + (forall (b:bits), + (forall (fmt:(format Z)), (rt_from_bits b fmt) = + (cint_of_bits fmt (mbits_to_bbits b)))). +Admitted. + +(Why logic) Definition bbits_to_mbyte : Z -> (array bool) -> bits. +Admitted. + +(Why axiom) Lemma bbits_to_mbyte_size : + (forall (b:(array bool)), + (forall (k:Z), (bits_size (bbits_to_mbyte k b)) = 8)). +Admitted. + +(Why axiom) Lemma bbits_to_mbyte_def : + (forall (b:(array bool)), + (forall (k:Z), + (forall (i:Z), + (0 <= i /\ i < 8 -> + (nth_bit (bbits_to_mbyte k b) i) = (access b (8 * k + 7 - i)))))). +Admitted. + +(Why logic) Definition bbits_to_mbits : Z -> (array bool) -> bits. +Admitted. + +(Why axiom) Lemma bbits_to_mb8 : + (forall (b:(array bool)), (bbits_to_mbits 8 b) = (bbits_to_mbyte 0 b)). +Admitted. + +(Why axiom) Lemma bbits_to_little_mb16 : + (forall (b:(array bool)), + (little_endian -> + (bbits_to_mbits 16 b) = + (bits_concat (bbits_to_mbyte 0 b) (bbits_to_mbyte 1 b)))). +Admitted. + +(Why axiom) Lemma bbits_to_big_mb16 : + (forall (b:(array bool)), + (~little_endian -> + (bbits_to_mbits 16 b) = + (bits_concat (bbits_to_mbyte 1 b) (bbits_to_mbyte 0 b)))). +Admitted. + +(Why axiom) Lemma bbits_to_little_mb32 : + (forall (b:(array bool)), + (little_endian -> + (bbits_to_mbits 32 b) = + (bits_concat + (bbits_to_mbyte 0 b) (bits_concat + (bbits_to_mbyte 1 b) (bits_concat + (bbits_to_mbyte 2 b) ( + bbits_to_mbyte 3 b)))))). +Admitted. + +(Why axiom) Lemma bbits_to_not_mb32 : + (forall (b:(array bool)), + (~little_endian -> + (bbits_to_mbits 32 b) = + (bits_concat + (bbits_to_mbyte 3 b) (bits_concat + (bbits_to_mbyte 2 b) (bits_concat + (bbits_to_mbyte 1 b) ( + bbits_to_mbyte 0 b)))))). +Admitted. + +(Why axiom) Lemma rt_int_to_bits : + (forall (x:Z), + (forall (fmt:(format Z)), + (rt_to_bits fmt x) = + (bbits_to_mbits (format_size fmt) (bits_of_cint fmt x)))). +Admitted. + +(Why type) Definition memory: Set. +Admitted. + +(Why type) Definition memalloc: Set. +Admitted. + +(Why logic) Definition rt_valid : memalloc -> zone -> Prop. +Admitted. + +(Why axiom) Lemma incl_valid : + (forall (m:memalloc), + (forall (z:zone), + (forall (z':zone), + ((rt_incl z' z) -> ((rt_valid m z) -> (rt_valid m z')))))). +Admitted. + +(Why axiom) Lemma disj_valid : + (forall (m:memalloc), + (forall (z:zone), + (forall (z':zone), + ((rt_valid m z) -> (~(rt_valid m z') -> (rt_disj z z')))))). +Admitted. + +(Why logic) Definition rt_zbase : memalloc -> Z -> zone. +Admitted. + +(Why function) Definition rt_abase (m:memalloc) (addr:Z) + := (z_addr (rt_zbase m addr)). + +(Why logic) Definition rt_block_length : memalloc -> Z -> Z. +Admitted. + +(Why type) Definition mz: Set. +Admitted. + +(Why logic) Definition mem_of_mz : mz -> memalloc. +Admitted. + +(Why logic) Definition addr_of_mz : mz -> Z. +Admitted. + +(Why logic) Definition rt_alloc : memalloc -> Z -> mz. +Admitted. + +(Why function) Definition alloc_zone (m:memalloc) (sz:Z) + := (rt_zone (addr_of_mz (rt_alloc m sz)) sz). + +(Why axiom) Lemma alloc_is_base : + (forall (m:memalloc), + (forall (sz:Z), + let mz := (rt_alloc m sz) in + (rt_zbase (mem_of_mz mz) (addr_of_mz mz)) = (alloc_zone m sz))). +Admitted. + +(Why axiom) Lemma valid_alloc : + (forall (m:memalloc), + (forall (sz:Z), + let mz := (rt_alloc m sz) in + (rt_valid (mem_of_mz mz) (alloc_zone m sz)))). +Admitted. + +(Why axiom) Lemma not_valid_before_alloc : + (forall (m:memalloc), (forall (sz:Z), ~(rt_valid m (alloc_zone m sz)))). +Admitted. + +(Why axiom) Lemma alloc_keep_valid : + (forall (m:memalloc), + (forall (sz:Z), + (forall (z:zone), + ((rt_valid m z) -> + let mz := (rt_alloc m sz) in + (rt_valid (mem_of_mz mz) z))))). +Admitted. + +(Why axiom) Lemma alloc_keep_invalid : + (forall (m:memalloc), + (forall (sz:Z), + (forall (z:zone), + let mz := (rt_alloc m sz) in + ((rt_valid (mem_of_mz mz) z) -> + ((rt_disj (alloc_zone m sz) z) -> (rt_valid m z)))))). +Admitted. + +(Why logic) Definition rt_free : memalloc -> Z -> memalloc. +Admitted. + +(Why axiom) Lemma not_valid_after_free : + (forall (m:memalloc), + (forall (addr:Z), + (forall (z:zone), + (z = (rt_zbase m addr) -> + (addr = (z_addr z) -> ~(rt_valid (rt_free m addr) z)))))). +Admitted. + +(Why axiom) Lemma valid_free_disj : + (forall (m:memalloc), + (forall (z:zone), + (forall (z':zone), + ((rt_valid (rt_free m (z_addr z)) z') <-> (rt_disj z z'))))). +Admitted. + +(Why logic) Definition rt_vaddr : memalloc -> Z -> Z. +Admitted. + +(Why logic) Definition rt_vsize : Z -> Z. +Admitted. + +(Why function) Definition rt_vzone (ma:memalloc) (var:Z) + := (rt_zone (rt_vaddr ma var) (rt_vsize var)). + +(Why logic) Definition rt_global : Z -> Prop. +Admitted. + +(Why axiom) Lemma rt_global_vaddr : + (forall (v:Z), + ((rt_global v) -> + (forall (ma:memalloc), + (forall (ma':memalloc), (rt_vaddr ma v) = (rt_vaddr ma' v))))). +Admitted. + +(Why axiom) Lemma rt_global_valid : + (forall (ma:memalloc), + (forall (v:Z), + ((rt_global v) -> + (forall (ma:memalloc), + (forall (ma':memalloc), (rt_valid ma (rt_vzone ma' v))))))). +Admitted. + +(Why axiom) Lemma vzone_disj : + (forall (ma:memalloc), + (forall (v1:Z), + (forall (v2:Z), + (v1 <> v2 -> + let z1 := (rt_vzone ma v1) in + let z2 := (rt_vzone ma v2) in + ((rt_valid ma z1) -> ((rt_valid ma z2) -> (rt_disj z1 z2))))))). +Admitted. + +(Why logic) Definition rt_valloc : memalloc -> Z -> memalloc. +Admitted. + +(Why axiom) Lemma rt_valloc_mem : + (forall (ma:memalloc), + (forall (var:Z), + (rt_valloc ma var) = (mem_of_mz (rt_alloc ma (rt_vsize var))))). +Admitted. + +(Why axiom) Lemma rt_valloc_addr : + (forall (ma:memalloc), + (forall (var:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma var) -> + (forall (mz:mz), + (mz = (rt_alloc ma (rt_vsize var)) -> (rt_vaddr ma' var) = + (addr_of_mz mz))))))). +Admitted. + +(Why axiom) Lemma vzone_valloc_neq : + (forall (ma:memalloc), + (forall (v1:Z), + (forall (v2:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v1) -> + (v1 <> v2 -> (rt_vzone ma' v2) = (rt_vzone ma v2))))))). +Admitted. + +(Why function) Definition rt_vfree (ma:memalloc) (var:Z) + := (rt_free ma (rt_vaddr ma var)). + +(Why axiom) Lemma rt_vaddr_vfree : + (forall (ma:memalloc), + (forall (v1:Z), + (forall (v2:Z), + (v1 <> v2 -> (rt_vaddr (rt_vfree ma v1) v2) = (rt_vaddr ma v2))))). +Admitted. + +(Why axiom) Lemma addr_base : + (forall (m:memalloc), + (forall (v:Z), (rt_abase m (rt_vaddr m v)) = (rt_vaddr m v))). +Admitted. + +(Why logic) Definition rt_load : memory -> zone -> bits. +Admitted. + +(Why logic) Definition rt_store : memory -> Z -> bits -> memory. +Admitted. + +(Why axiom) Lemma load_store_same : + (forall (m:memory), + (forall (a:Z), + (forall (z:zone), + (forall (v:bits), + (z = (rt_zone a (bits_size v)) -> (rt_load (rt_store m a v) z) = v))))). +Admitted. + +(Why axiom) Lemma load_store_disj : + (forall (m:memory), + (forall (a:Z), + (forall (z:zone), + (forall (v:bits), + ((rt_disj (rt_zone a (bits_size v)) z) -> + (rt_load (rt_store m a v) z) = (rt_load m z)))))). +Admitted. + +(Why axiom) Lemma load_store_incl_part : + (forall (m:memory), + (forall (a:Z), + (forall (z1:zone), + (forall (z2:zone), + (forall (v:bits), + (z2 = (rt_zone a (bits_size v)) -> + ((rt_incl z1 z2) -> + (rt_load (rt_store m a v) z1) = + (bits_part v ((z_addr z1) - a) (z_size z1))))))))). +Admitted. + +(Why axiom) Lemma load_incl_part_store : + (forall (m:memory), + (forall (z1:zone), + (forall (z2:zone), + (forall (v:bits), + (forall (a:Z), + (z1 = (rt_zone a (bits_size v)) -> + (forall (off:Z), + (off = (a - (z_addr z2)) -> + ((rt_incl z1 z2) -> + (rt_load (rt_store m a v) z2) = + (wr_bits_part (rt_load m z2) off v)))))))))). +Admitted. + +(Why axiom) Lemma rt_load_size : + (forall (m:memory), + (forall (z:zone), (bits_size (rt_load m z)) = (z_size z))). +Admitted. + +(Why axiom) Lemma bits_part_rt_load : + (forall (z:zone), + (forall (z':zone), + (forall (a':Z), + (forall (off:Z), + (forall (sz:Z), + (a' = ((z_addr z) + off) -> + (z' = (rt_zone a' sz) -> + ((rt_incl z' z) -> + (forall (m:memory), + (rt_load m z') = (bits_part (rt_load m z) off sz)))))))))). +Admitted. + +(Why axiom) Lemma rt_same_mem : + (forall (m1:memory), + (forall (m2:memory), + ((forall (z:zone), (rt_load m1 z) = (rt_load m2 z)) -> m1 = m2))). +Admitted. + +(Why logic) Definition rt_havoc : memory -> zone -> memory. +Admitted. + +(Why predicate) Definition rt_is_havoc (ma:memalloc) (m1:memory) (zs:zones) (m2:memory) + := (forall (z:zone), + ((rt_valid ma z) -> + ((zs_z_disj z zs) -> (rt_load m1 z) = (rt_load m2 z)))). + +(Why axiom) Lemma rt_havoc_is_havoc : + (forall (ma:memalloc), + (forall (m:memory), + (forall (zs:zones), + (forall (z:zone), + ((zs_z_incl z zs) -> (rt_is_havoc ma m zs (rt_havoc m z))))))). +Admitted. + +(Why logic) Definition rt_addr_format : (format Z). +Admitted. + +(Why axiom) Lemma rt_vaddr_format : + (forall (ma:memalloc), + (forall (v:Z), (is_in_format rt_addr_format (rt_vaddr ma v)))). +Admitted. + +(Why axiom) Lemma bits_part_vs_access : + (forall (bs:bits), + (forall (fs:(format (array data))), + (forall (f:Z), + (forall (off:Z), + (forall (sz:Z), + (off = (rt_foffset f) -> + (sz = (rt_fsize f) -> + (rt_from_bits (bits_part bs off sz) (rt_fformat f)) = + (decode int_format (access (rt_from_bits bs fs) f))))))))). +Admitted. + +(Why logic) Definition rt_addr_lt : Z -> Z -> Prop. +Admitted. + +(Why logic) Definition rt_addr_le : Z -> Z -> Prop. +Admitted. + +(Why logic) Definition rt_addr_lt_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition rt_addr_le_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition rt_addr_minus : Z -> Z -> Z. +Admitted. + +(Why logic) Definition rt_addr_eq : Z -> Z -> Prop. +Admitted. + +(Why logic) Definition rt_addr_eq_bool : Z -> Z -> bool. +Admitted. + +(Why axiom) Lemma rt_disj_sym : + (forall (z1:zone), + (forall (z2:zone), ((rt_disj z1 z2) <-> (rt_disj z2 z1)))). +Admitted. + +(Why axiom) Lemma rt_disj_shift : + (forall (addr:Z), + (forall (i:Z), + (forall (j:Z), + (forall (sz:Z), + (sz > 0 -> + (i <> j -> + (rt_disj + (rt_zone (rt_shift addr (i * sz)) sz) (rt_zone + (rt_shift addr (j * sz)) sz)))))))). +Admitted. + +(Why axiom) Lemma vzone_of_zone : + (forall (ma:memalloc), + (forall (v:Z), + (forall (a:Z), + (forall (sz:Z), + (a = (rt_vaddr ma v) -> + (sz = (rt_vsize v) -> (rt_zone a sz) = (rt_vzone ma v))))))). +Admitted. + +(Why axiom) Lemma bits_part_full : + (forall (v:bits), + (forall (sz:Z), (sz = (bits_size v) -> (bits_part v 0 sz) = v))). +Admitted. + +(Why axiom) Lemma bits_part_of_bits_part : + (forall (b:bits), + (forall (o1:Z), + (forall (o2:Z), + (forall (sz1:Z), + (forall (sz2:Z), + (0 <= o1 -> + ((o1 + sz1) <= (bits_size b) -> + (0 <= o2 -> + ((o2 + sz2) <= sz1 -> + (bits_part (bits_part b o1 sz1) o2 sz2) = + (bits_part b (o1 + o2) sz2)))))))))). +Admitted. + +(Why axiom) Lemma eq_bits_split : + (forall (b1:bits), + (forall (b2:bits), + (forall (sz:Z), + ((bits_size b1) = sz -> + ((bits_size b2) = sz -> + (forall (sz1:Z), + (forall (sz2:Z), + (sz1 >= 0 -> + (sz2 >= 0 -> + ((sz1 + sz2) = sz -> + ((bits_part b1 0 sz1) = (bits_part b2 0 sz1) -> + ((bits_part b1 sz1 sz2) = (bits_part b2 sz1 sz2) -> b1 = b2)))))))))))). +Admitted. + +(Why axiom) Lemma wr_bits_part_all : + (forall (v:bits), + (forall (v':bits), + ((bits_size v) = (bits_size v') -> (wr_bits_part v 0 v') = v'))). +Admitted. + +(Why axiom) Lemma wr_bits_part_concat : + (forall (b:bits), + (forall (b':bits), + (forall (sz1:Z), + (forall (sz2:Z), + (forall (sz3:Z), + (0 <= sz1 -> + (sz2 = (bits_size b') -> + (0 <= sz3 -> + ((sz1 + sz2 + sz3) = (bits_size b) -> + (wr_bits_part b sz1 b') = + (bits_concat + (bits_part b 0 sz1) (bits_concat b' (bits_part b (sz1 + sz2) sz3)))))))))))). +Admitted. + +(Why axiom) Lemma wr_bits_part_same : + (forall (b1:bits), + (forall (b2:bits), + (forall (off:Z), + (0 <= off -> + ((off + (bits_size b2)) <= (bits_size b1) -> + (bits_part (wr_bits_part b1 off b2) off (bits_size b2)) = b2))))). +Admitted. + +(Why axiom) Lemma wr_bits_part_disj : + (forall (b:bits), + (forall (b1:bits), + (forall (off2:Z), + (forall (off1:Z), + (forall (sz:Z), + (forall (sz1:Z), + (forall (sz2:Z), + (sz = (bits_size b) -> + (sz1 = (bits_size b1) -> + (0 <= off1 -> + ((off1 + sz1) <= sz -> + (0 <= off2 -> + ((off2 + sz2) <= sz -> + ((off2 + sz2) <= off1 \/ (off1 + sz1) <= off2 -> + (bits_part (wr_bits_part b off1 b1) off2 sz2) = + (bits_part b off2 sz2))))))))))))))). +Admitted. + +(Why axiom) Lemma rt_z_from_bits_to_bits_zero : + (forall (fmt:(format Z)), + (forall (fmt':(format Z)), (rt_from_bits (rt_to_bits fmt 0) fmt') = 0)). +Admitted. + +(Why axiom) Lemma bits_part_zero : + (forall (b:bits), + (forall (b':bits), + (forall (off:Z), + (forall (sz:Z), + (0 <= off -> + ((off + sz) <= (bits_size b) -> + (b' = (bits_part b off sz) -> ((zero_bits b) -> (zero_bits b'))))))))). +Admitted. + +(Why axiom) Lemma rw_same_var : + (forall (m:memory), + (forall (ma:memalloc), + (forall (v:Z), + (forall (val:bits), + ((bits_size val) = (rt_vsize v) -> + (rt_load (rt_store m (rt_vaddr ma v) val) (rt_vzone ma v)) = val))))). +Admitted. + +(Why axiom) Lemma rw_disj_var : + (forall (ma:memalloc), + (forall (m:memory), + (forall (v1:Z), + (forall (v2:Z), + (forall (z1:zone), + (forall (z2:zone), + (forall (b:bits), + (v1 <> v2 -> + (z1 = (rt_vzone ma v1) -> + (z2 = (rt_vzone ma v2) -> + ((rt_valid ma z1) -> + ((rt_valid ma z2) -> + ((rt_vsize v2) = (bits_size b) -> + (rt_load (rt_store m (rt_vaddr ma v2) b) z1) = (rt_load m z1)))))))))))))). +Admitted. + +(Why axiom) Lemma store_concat : + (forall (m:memory), + (forall (m1:memory), + (forall (a:Z), + (forall (b1:bits), + (forall (b2:bits), + (forall (sz1:Z), + (sz1 = (bits_size b1) -> + (m1 = (rt_store m a b1) -> + (rt_store m1 (a + sz1) b2) = (rt_store m a (bits_concat b1 b2)))))))))). +Admitted. + +(Why axiom) Lemma store_disj_commut : + (forall (m:memory), + (forall (a1:Z), + (forall (a2:Z), + (forall (b1:bits), + (forall (b2:bits), + ((rt_disj (rt_zone a1 (bits_size b1)) (rt_zone a2 (bits_size b2))) -> + (rt_store (rt_store m a1 b1) a2 b2) = + (rt_store (rt_store m a2 b2) a1 b1))))))). +Admitted. + +(Why axiom) Lemma not_valid_before_valloc : + (forall (ma:memalloc), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> ~(rt_valid ma (rt_vzone ma' v)))))). +Admitted. + +(Why axiom) Lemma valid_valloc : + (forall (ma:memalloc), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> (rt_valid ma' (rt_vzone ma' v)))))). +Admitted. + +(Why axiom) Lemma valloc_keep_valid_zone : + (forall (ma:memalloc), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> + (forall (z:zone), ((rt_valid ma z) -> (rt_valid ma' z))))))). +Admitted. + +(Why axiom) Lemma valloc_keep_valid_disj_zone : + (forall (ma:memalloc), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> + (forall (z:zone), + ((rt_disj (rt_vzone ma' v) z) -> ((rt_valid ma' z) -> (rt_valid ma z)))))))). +Admitted. + +(Why axiom) Lemma valloc_keep_invalid_zone : + (forall (ma:memalloc), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> + (forall (z:zone), + ((rt_disj (rt_vzone ma' v) z) -> + (~(rt_valid ma z) -> ~(rt_valid ma' z)))))))). +Admitted. + +(Why axiom) Lemma valloc_keep_invalid_zone_rev : + (forall (ma:memalloc), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> + (forall (z:zone), + ((rt_disj (rt_vzone ma' v) z) -> + (~(rt_valid ma' z) -> ~(rt_valid ma z)))))))). +Admitted. + +(Why axiom) Lemma valloc_keep_valid_var : + (forall (ma:memalloc), + (forall (v1:Z), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> + (v <> v1 -> + ((rt_valid ma (rt_vzone ma v1)) -> (rt_valid ma' (rt_vzone ma' v1))))))))). +Admitted. + +(Why axiom) Lemma valloc_keep_vaddr : + (forall (ma:memalloc), + (forall (v1:Z), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> + (v <> v1 -> (rt_vaddr ma' v1) = (rt_vaddr ma v1))))))). +Admitted. + +(Why axiom) Lemma valloc_keep_vzone : + (forall (ma:memalloc), + (forall (v1:Z), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_valloc ma v) -> + (v <> v1 -> (rt_vzone ma' v1) = (rt_vzone ma v1))))))). +Admitted. + +(Why axiom) Lemma vzone_vfree : + (forall (ma:memalloc), + (forall (v1:Z), + (forall (v2:Z), + (forall (ma':memalloc), + (ma' = (rt_vfree ma v1) -> + (v1 <> v2 -> (rt_vzone ma' v2) = (rt_vzone ma v2))))))). +Admitted. + +(Why axiom) Lemma not_valid_after_vfree : + (forall (ma:memalloc), + (forall (v:Z), + (forall (ma':memalloc), + (ma' = (rt_vfree ma v) -> + (forall (z:zone), (z = (rt_vzone ma v) -> ~(rt_valid ma' z))))))). +Admitted. + +(Why axiom) Lemma havoc_store : + (forall (ma:memalloc), + (forall (m1:memory), + (forall (m2:memory), + (forall (zs:zones), + (forall (z:zone), + (forall (x:bits), + (forall (a:Z), + (z = (rt_zone a (bits_size x)) -> + ((rt_is_havoc ma m1 zs m2) -> + ((zs_z_incl z zs) -> (rt_is_havoc ma m1 zs (rt_store m2 a x)))))))))))). +Admitted. + +(Why axiom) Lemma havoc_invalid : + (forall (ma:memalloc), + (forall (m1:memory), + (forall (m2:memory), + (forall (zs:zones), + (forall (z:zone), + (forall (x:bits), + (forall (a:Z), + (z = (rt_zone a (bits_size x)) -> + ((rt_is_havoc ma m1 zs m2) -> + (~(rt_valid ma z) -> (rt_is_havoc ma m1 zs (rt_store m2 a x)))))))))))). +Admitted. + +(Why axiom) Lemma same_bits_same_val : + forall (A1:Set), + (forall (b1:bits), + (forall (b2:bits), + (forall (fmt:(format A1)), + (b1 = b2 -> (rt_from_bits b1 fmt) = (rt_from_bits b2 fmt))))). +Admitted. + +(Why axiom) Lemma valid_vglob : + (forall (v:Z), + ((rt_global v) -> + (forall (ma:memalloc), + (forall (ma':memalloc), (rt_valid ma (rt_vzone ma' v)))))). +Admitted. + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/runtime_model.why frama-c-20111001+nitrogen+dfsg/src/wp/share/runtime_model.why --- frama-c-20110201+carbon+dfsg/src/wp/share/runtime_model.why 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/runtime_model.why 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,1514 @@ +(* --- Headers for WHY --- ) + +include "bool.why" +include "integer.why" +include "real.why" +include "arrays.why" +include "divisions.why" +( -------------------------------------------------------------------------- ) +( --- ACSL Definitions --- ) +( -------------------------------------------------------------------------- ) + +logic dummy : int -> prop +logic assigns : int -> prop + + +( -------------------------------------------------------------------------- ) +( --- Divisions enhanced specification --- ) +( -------------------------------------------------------------------------- *) + +axiom positive_computer_div_div: + forall x,y:int. + x >0 -> y >0 -> computer_div(x,y) = math_div(x,y) + + +(************************************************************************) +(* Specification of Set as First Class Value *) +(************************************************************************) +(* From Figure 2.6 in ACSL:ANSI/ISO C Specification Language ) + +type 'a set + +logic empty : 'a set +logic singleton : 'a -> 'a set +logic range : int,int -> int set +logic union : 'a set , 'a set -> 'a set +logic inter : 'a set , 'a set -> 'a set +logic plus_int : int set, int set -> int set +logic subset : 'a set,'a set -> prop +logic range_inf: int -> int set +logic range_sup:int->int set +logic integers_set : int set +logic equiv : 'a set ,'a set -> prop +logic member : 'a,'a set -> prop + +axiom singleton_def : + forall x:'a. member (x, singleton(x)) + +axiom singleton_eq: + forall x,y:'a. member(x,singleton(y)) <-> x=y + +axiom union_member : + forall x:'a. forall s1,s2:'a set [member(x, union(s1,s2))]. + member(x, union(s1,s2)) <-> member(x,s1) or member(x,s2) + +axiom union_of_empty : + forall x:'a set [union(x,empty)]. union(x,empty) = x + +axiom inter_of_empty : + forall x:'a set [inter(x,empty)]. inter(x,empty) = empty + +axiom union_comm : + forall x,y:'a set. union(x,y) = union(y,x) + +axiom inter_comm : + forall x,y:'a set. inter(x,y) = inter(y,x) + +axiom inter_member : + forall x:'a. forall s1,s2:'a set [member(x,inter(s1,s2))]. + member(x,inter(s1,s2)) <-> member(x,s1) and member(x,s2) + +axiom plus_int_member_1: + forall sa,sb:int set. + forall a,b:int [member((a+b), plus_int(sa,sb))]. + member(a,sa) -> member(b,sb) -> + member((a+b), plus_int(sa,sb)) + +axiom plus_int_member_2: + forall sa,sb:int set. + forall c:int. + member(c,plus_int(sa,sb)) -> + exists a:int. exists b:int. + member(a,sa) and member(b,sb) and c=a+b + +axiom subset_empty : + forall sa:'a set. subset(empty,sa) + +axiom subset_sym: + forall sa:'a set. subset(sa,sa) + +axiom subset_trans : + forall sa,sb,sc: 'a set. + subset(sa,sb) -> + subset(sb,sc) -> + subset(sa,sc) + +axiom subset_def: + forall sa,sb:'a set [subset(sa,sb)]. + (forall a:'a. member(a,sa) -> member(a,sb)) <-> subset(sa,sb) + + +axiom range_def: + forall i,j,k:int. i <= k<= j <-> member (k,range(i,j)) + +axiom range_def1: + forall i,j,k:int. i <= k<= j -> member (k,range(i,j)) + +axiom range_def2: + forall i,j,k:int.member (k,range(i,j)) -> i <= k<= j + +axiom range_inf_def: ( range_inf(i) is [ i .. ] ) + forall i,k: int. i <= k <-> member (k,range_inf(i)) + +axiom range_sup_def: ( range_sup(j) is [ .. j ] *) + forall j,k: int. k <= j <-> member (k,range_sup(j)) + +axiom integers_set_def: + forall k:int. k >= 0 <-> member(k,integers_set) + +axiom equiv_def: + forall s1,s2:'a set [equiv(s1,s2)]. ( + (forall a:'a. member(a,s1) -> member(a,s2)) and + (forall b:'a. member(b,s2) -> member(b,s1))) <-> + equiv(s1,s2) + +axiom equiv_refl: + forall s:'a set. equiv(s,s) + +axiom equiv_sym: + forall s1,s2:'a set. equiv(s1,s2) -> equiv(s2,s1) + +axiom equiv_trans: + forall s1,s2,s3:'a set. + equiv(s1,s2) -> equiv(s2,s3) -> equiv(s1,s3) + + + +(************************************************************************) +(* Integers and Reals ) +() + + +logic as_uint8 :int -> int +predicate is_uint8(x:int) = 0 <= x < 256 +axiom as_uint8_def : forall x:int. is_uint8(as_uint8(x)) +axiom as_uint8_involve : + forall x:int [as_uint8(as_uint8(x))]. as_uint8(as_uint8(x)) = as_uint8(x) +axiom is_as_uint8: forall x:int [as_uint8(x)]. is_uint8(x) -> as_uint8(x) = x + +logic as_sint8 :int -> int +predicate is_sint8(x:int) = -128 <= x < 128 +axiom as_sint8_def : forall x:int. is_sint8(as_sint8(x)) +axiom as_sint8_involve : + forall x:int [as_sint8(as_sint8(x))]. as_sint8(as_sint8(x)) = as_sint8(x) +axiom is_as_sint8: forall x:int[as_sint8(x)]. is_sint8(x) -> as_sint8(x) = x + + +logic as_uint16 :int -> int +predicate is_uint16(x:int) = 0 <= x < 65536 +axiom as_uint16_def : forall x:int. is_uint16(as_uint16(x)) +axiom as_uint16_involve : + forall x:int [as_uint16(as_uint16(x))]. + as_uint16(as_uint16(x)) = as_uint16(x) +axiom is_as_uint16: forall x:int [as_uint16(x)]. is_uint16(x) -> as_uint16(x) = x + +logic as_sint16 :int -> int +predicate is_sint16(x:int) = -32768 <= x < 32768 +axiom as_sint16_def : forall x:int. is_sint16(as_sint16(x)) +axiom as_sint16_involve : + forall x:int [as_sint16(as_sint16(x))]. + as_sint16(as_sint16(x)) = as_sint16(x) +axiom is_as_sint16: forall x:int [as_sint16(x)]. is_sint16(x) -> as_sint16(x) = x + + +logic as_uint32 :int -> int +predicate is_uint32(x:int) = 0 <= x < 4294967296 +axiom as_uint32_def : forall x:int. is_uint32(as_uint32(x)) +axiom as_uint32_involve : + forall x:int [as_uint32(as_uint32(x))]. + as_uint32(as_uint32(x)) = as_uint32(x) +axiom is_as_uint32: forall x:int [as_uint32(x)]. is_uint32(x) -> as_uint32(x) = x + +logic as_sint32 :int -> int +predicate is_sint32(x:int) = -2147483648 <= x < 2147483648 +axiom as_sint32_def : forall x:int. is_sint32(as_sint32(x)) +axiom as_sint32_involve : + forall x:int [as_sint32(as_sint32(x))]. + as_sint32(as_sint32(x)) = as_sint32(x) +axiom is_as_sint32: forall x:int [as_sint32(x)]. is_sint32(x) -> as_sint32(x) = x + + +logic as_uint64 :int -> int +predicate is_uint64(x:int) = 0 <= x < 18446744073709551616 +axiom as_uint64_def : forall x:int. is_uint64(as_uint64(x)) +axiom as_uint64_involve : + forall x:int [as_uint64(as_uint64(x))]. + as_uint64(as_uint64(x)) = as_uint64(x) +axiom is_as_uint64: forall x:int [as_uint64(x)]. is_uint64(x) -> as_uint64(x) = x + +logic as_sint64 :int -> int +predicate is_sint64(x:int) = -9223372036854775808 <= x < 9223372036854775808 +axiom as_sint64_def : forall x:int. is_sint64(as_sint64(x)) +axiom as_sint64_involve : + forall x:int [as_sint64(as_sint64(x))]. + as_sint64(as_sint64(x)) = as_sint64(x) +axiom is_as_sint64: forall x:int [as_sint64(x)]. is_sint64(x) -> as_sint64(x) = x + + +logic as_float16 :real -> real +logic is_float16 :real -> prop +axiom as_float16_def : forall x:real. is_float16(as_float16(x)) +axiom as_float16_involve : + forall x:real [as_float16(as_float16(x))]. + as_float16(as_float16(x)) = as_float16(x) +axiom is_as_float16: forall x:real [as_float16(x)]. is_float16(x) -> as_float16(x) = x + + +logic as_float32 :real -> real +logic is_float32 :real -> prop +axiom as_float32_def : forall x:real. is_float32(as_float32(x)) +axiom as_float32_involve : + forall x:real [as_float32(as_float32(x))]. + as_float32(as_float32(x)) = as_float32(x) +axiom is_as_float32: + forall x:real [as_float32(x)]. is_float32(x) -> as_float32(x) = x + + +logic as_float64 :real -> real +logic is_float64 :real -> prop +axiom as_float64_def : + forall x:real. is_float64(as_float64(x)) +axiom as_float64_involve : + forall x:real [as_float64(as_float64(x))]. + as_float64(as_float64(x)) = as_float64(x) +axiom is_as_float64: + forall x:real [as_float64(x)]. is_float64(x) -> as_float64(x) = x + + +logic as_float128 :real -> real +logic is_float128 :real -> prop +axiom as_float128_def : + forall x:real. is_float128(as_float128(x)) +axiom as_float128_involve : + forall x:real [as_float128(as_float128(x))]. + as_float128(as_float128(x)) = as_float128(x) +axiom is_as_float128: + forall x:real [as_float128(x)]. is_float128(x) -> as_float128(x) = x + +() +( Memory Data Type ) +() + +type data + +logic data_of_uint8: int -> data +logic uint8_of_data: data -> int + +axiom is_uint8_of_data: + forall d:data [is_uint8(uint8_of_data(d))].is_uint8(uint8_of_data(d)) + +axiom uint8ofdata_dataofuint8: + forall x:int [data_of_uint8(x)]. + is_uint8(x) -> uint8_of_data(data_of_uint8(x)) = x + +logic data_of_sint8: int -> data +logic sint8_of_data: data -> int + +axiom is_sint8_of_data: + forall d:data [is_sint8(sint8_of_data(d))]. is_sint8(sint8_of_data(d)) + +axiom sint8ofdata_dataofsint8: + forall x:int [data_of_sint8(x)]. + is_sint8(x) -> sint8_of_data(data_of_sint8(x)) = x + +logic data_of_uint16: int -> data +logic uint16_of_data: data -> int + +axiom is_uint16_of_data: + forall d:data [is_uint16(uint16_of_data(d))]. is_uint16(uint16_of_data(d)) + +axiom uint16ofdata_dataofuint16: + forall x:int [uint16_of_data(data_of_uint16(x))]. + is_uint16(x) -> uint16_of_data(data_of_uint16(x)) = x + +logic data_of_sint16: int -> data +logic sint16_of_data: data -> int + +axiom is_sint16_of_data: + forall d:data [is_sint16(sint16_of_data(d))]. is_sint16(sint16_of_data(d)) + +axiom sint16ofdata_dataofsint16: + forall x:int [data_of_sint16(x)]. + is_sint16(x) -> sint16_of_data(data_of_sint16(x)) = x + +logic data_of_uint32: int -> data +logic uint32_of_data: data -> int + +axiom is_uint32_of_data: + forall d:data [is_uint32(uint32_of_data(d))]. is_uint32(uint32_of_data(d)) + +axiom uint32ofdata_dataofuint32: + forall x:int [data_of_uint32(x)]. + is_uint32(x) -> uint32_of_data(data_of_uint32(x)) = x + +logic data_of_sint32: int -> data +logic sint32_of_data: data -> int + +axiom is_sint32_of_data: + forall d:data [is_sint32(sint32_of_data(d))]. is_sint32(sint32_of_data(d)) + +axiom sint32ofdata_dataofsint32: + forall x:int [data_of_sint32(x)]. + is_sint32(x) -> sint32_of_data(data_of_sint32(x)) = x + +logic data_of_uint64: int -> data +logic uint64_of_data: data -> int + +axiom is_uint64_of_data: + forall d:data [is_uint64(uint64_of_data(d))]. is_uint64(uint64_of_data(d)) + +axiom uint64ofdata_dataofuint64: + forall x:int [data_of_uint64(x)]. + is_uint64(x) -> uint64_of_data(data_of_uint64(x)) = x + +logic data_of_sint64: int -> data +logic sint64_of_data: data -> int + +axiom is_sint64_of_data: + forall d:data [is_sint64(sint64_of_data(d))]. is_sint64(sint64_of_data(d)) + +axiom sint64ofdata_dataofsint64: + forall x:int [data_of_sint64(x)]. + is_sint64(x) -> sint64_of_data(data_of_sint64(x)) = x + +logic data_of_float16: real -> data +logic float16_of_data: data -> real + +axiom is_float16_of_data: + forall d:data [is_float16(float16_of_data(d))]. is_float16(float16_of_data(d)) +axiom float16ofdata_dataoffloat16: + forall x:real [data_of_float16(x)]. + is_float16(x) -> float16_of_data(data_of_float16(x)) = x + +logic data_of_float32: real -> data +logic float32_of_data: data -> real + +axiom is_float32_of_data: + forall d:data [is_float32(float32_of_data(d))]. is_float32(float32_of_data(d)) +axiom float32ofdata_dataoffloat32: + forall x:real [data_of_float32(x)]. + is_float32(x) -> float32_of_data(data_of_float32(x)) = x + +logic data_of_float64: real -> data +logic float64_of_data: data -> real + +axiom is_float64_of_data: + forall d:data [is_float64(float64_of_data(d))]. is_float64(float64_of_data(d)) +axiom float64ofdata_dataoffloat64: + forall x:real [data_of_float64(x)]. + is_float64(x) -> float64_of_data(data_of_float64(x)) = x + +logic data_of_float128: real -> data +logic float128_of_data: data -> real + +axiom is_float128_of_data: + forall d:data [is_float128(float128_of_data(d))]. is_float128(float128_of_data(d)) +axiom float128ofdata_dataoffloat128: + forall x:real [data_of_float128(x)]. + is_float128(x) -> float128_of_data(data_of_float128(x)) = x + + +() +( Update of Arrays over a set of Index *) +(************************************************************************) + + +logic set_range_index: + 'a farray (* array), int set ( set of index), int (uniq key*) -> 'a farray + +axiom set_range_def : + forall t: 'a farray. + forall rg: int set. + forall k:int. + forall i:int [access(set_range_index(t,rg,k),i)]. + not (member(i,rg)) -> + access(set_range_index(t,rg,k),i) = access(t,i) + +(************************************************************************) +(* Bitwise Operations *) +(************************************************************************) + +logic bnot: int -> int +logic band: int,int -> int +logic bor: int,int -> int +logic bxor: int,int -> int +logic lshift: int,int -> int +logic rshift: int,int -> int + +logic int_not: int -> int +logic int_and: int,int -> int +logic int_or: int,int -> int +logic int_xor: int,int -> int +logic int_lsh: int,int -> int +logic int_rshs: int,int -> int +logic int_rshu: int,int -> int + +(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) +( WARNING: Generated file: any modifications will be lost ! ) +( See in the main file [data_lib.why] for more information. ) +( ~ ) + +type 'a format + +( [format_size f] number of bits of the format [f] ) +logic format_size : 'a format -> ( size ) int + +( [is_in_format f x] is true if [x] fits in the format [f] ) +( Ex: [is_in_format (uint8, 100)], but not is_in_format (uint8, (-1)) *) +logic is_in_format : 'a format, 'a -> prop + +(*********************************************************************) +(* Integer Cast into Machine *) +(*********************************************************************) + +(* [signed_format f] is the format [f] a signed one *) +logic signed_format : int format -> bool + + +(*** Definitions and sizes *) + +logic uint8_format : int format +axiom uint8_format_size : format_size (uint8_format) = 8 +axiom uint8_format_sign : signed_format (uint8_format) = false + +logic sint8_format : int format +axiom sint8_format_size : format_size (sint8_format) = 8 +axiom sint8_format_sign : signed_format (sint8_format) = true + +logic uint16_format : int format +axiom uint16_format_size : format_size (uint16_format) = 16 +axiom uint16_format_sign : signed_format (uint16_format) = false + +logic sint16_format : int format +axiom sint16_format_size : format_size (sint16_format) = 16 +axiom sint16_format_sign : signed_format (sint16_format) = true + +logic uint32_format : int format +axiom uint32_format_size : format_size (uint32_format) = 32 +axiom uint32_format_sign : signed_format (uint32_format) = false + +logic sint32_format : int format +axiom sint32_format_size : format_size (sint32_format) = 32 +axiom sint32_format_sign : signed_format (sint32_format) = true + +logic uint64_format : int format +axiom uint64_format_size : format_size (uint64_format) = 64 +axiom uint64_format_sign : signed_format (uint64_format) = false + +logic sint64_format : int format +axiom sint64_format_size : format_size (sint64_format) = 64 +axiom sint64_format_sign : signed_format (sint64_format) = true + +(*** Specifications ) + +axiom is_in_format_sint8 : forall x:int + [ is_in_format (sint8_format, x)]. + is_in_format (sint8_format, x) <-> -128 <= x < 128 + +axiom is_in_format_uint8 : forall x:int + [ is_in_format (uint8_format, x)]. + is_in_format (uint8_format, x) <-> 0 <= x < 256 + +axiom is_in_format_sint16 : forall x:int + [ is_in_format (sint16_format, x)]. + is_in_format (sint16_format, x) <-> -32768 <= x < 32768 + +axiom is_in_format_uint16 : forall x:int + [ is_in_format (uint16_format, x)]. + is_in_format (uint16_format, x) <-> 0 <= x < 65536 + +axiom is_in_format_sint32 : forall x:int + [ is_in_format (sint32_format, x)]. + is_in_format (sint32_format, x) <-> -2147483648 <= x < 2147483648 + +axiom is_in_format_uint32 : forall x:int + [ is_in_format (uint32_format, x)]. + is_in_format (uint32_format, x) <-> 0 <= x < 4294967296 + +axiom is_in_format_sint64 : forall x:int + [ is_in_format (sint64_format, x)]. + is_in_format (sint64_format, x) <-> -9223372036854775808 <= x < 9223372036854775808 + +axiom is_in_format_uint64 : forall x:int + [ is_in_format (uint64_format, x)]. + is_in_format (uint64_format, x) <-> 0 <= x < 18446744073709551616 + + +( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *) +(*** Floating point vs real ) + +( Be careful that [is_in_format] problably means that the real value + can be represented EXACTLY in the format... *) + +(*** Definitions and sizes ) + +logic float16_format : real format +axiom float16_format_size : format_size (float16_format) = 16 + +logic float32_format : real format +axiom float32_format_size : format_size (float32_format) = 32 + +logic float64_format : real format +axiom float64_format_size : format_size (float64_format) = 64 + +logic float96_format : real format +axiom float96_format_size : format_size (float96_format) = 96 + +logic float128_format : real format +axiom float128_format_size : format_size (float128_format) = 128 + +( ~ End of generated file data_int.why ) +( ~ ) + +( -------------------------------------------------------------------------- ) +( --- Runtime Memory Model --- ) +( -------------------------------------------------------------------------- *) +(**) +(* This file provides the definitions and axioms for the Runtime memory model. +Some lemmas, proved in coq from these definitions, are given in the file +[runtime_lemmas.why]. + +The Runtime memory model is a low level model where the memory can be seen +as an array of bits. + +Many types in his model are coded by [int] (address, size, etc.). +Because WHY doesn't allow type renaming, we'll try to specify them in comments. +*) + + +(************************************************************************) +(* Encode/Decode *) +(************************************************************************) + +logic encode : 'a format,'a -> data +logic decode : 'a format,data -> 'a + +axiom encode_decode: + forall f:'a format. forall d:data. + encode(f,decode(f,d)) = d + +axiom decode_encode: + forall f:'a format. forall x:'a. + decode(f,encode(f,x)) = x + +axiom decode_inj: + forall d,d':data. forall f:'a format. + decode(f,d) <> decode(f,d') <-> d<>d' + +axiom decode_eq: + forall d,d':data. forall f:'a format. + decode(f,d) = decode(f,d') <-> d=d' + + +logic int_format : int format +logic real_format : real format + + + +(========================================================================) +(* Casts ) +(========================================================================) + +(------------------------------------------------------------------------) +( Cast between [int format] ) + +logic as_int : int format, int -> int + +axiom simpl_as_int : forall f: int format. forall x:int. + is_in_format (f, x) -> as_int (f, x) = x +axiom as_int_def : forall f: int format. forall x:int. + is_in_format (f, (as_int (f, x))) +axiom involve_as_int : forall f: int format. forall x:int. + as_int (f, as_int (f, x)) = as_int (f, x) + +(------------------------------------------------------------------------) +( Cast between [real format] *) + +logic as_float : real format, real -> real + +axiom simpl_as_float : forall f: real format. forall x:real. + is_in_format (f, x) -> as_float (f, x) = x +axiom as_float_def : forall f: real format. forall x:real. + is_in_format (f, (as_float (f, x))) +axiom involve_as_float : forall f: real format. forall x:real. + as_float (f, as_float (f, x)) = as_float (f, x) + +(**) +(* === Addresses and zones === ) + +( New version of WHY support these new definitions, but unfortunatly, + it doesn't export them correctly to coq yet... + +type address = A (int) +type zone = rt_zone (int, int) (* = (address * size) ) +function z_addr (z:zone) : int = match z with rt_zone (a, sz) -> a end +function z_size (z:zone) : int = match z with rt_zone (a, sz) -> sz end + +) + +(* --- addresses --- ) +( An [address] is a kind of index in the memory. ) + +( type address = (* address ) int ) + +(* --- zones --- ) +( A [zone] is composed of an address and a size. ) + +( type size = (* size ) int ) + +type zone (* = rt_zone (int, int) = (address * size) ) + +logic rt_zone : ( address ) int, ( size ) int -> zone + +logic z_addr : zone -> ( address ) int +logic z_size : zone -> ( size ) int +axiom addr_zone : forall a, sz: int. z_addr (rt_zone (a, sz)) = a +axiom size_zone : forall a, sz: int. 0 <= sz -> z_size (rt_zone (a, sz)) = sz + +axiom rt_zone_inj : forall a1, a2, sz1, sz2 : int. + rt_zone (a1, sz1) = rt_zone (a2, sz2) <-> a1 = a2 and sz1 = sz2 + +predicate rt_disj (z1:zone, z2:zone) + = (z_addr (z1) + z_size (z1) <= z_addr (z2)) + or (z_addr (z2) + z_size (z2) <= z_addr (z1)) + +predicate rt_incl (z1:zone, z2:zone) + = z_addr (z2) <= z_addr (z1) +and z_addr (z1) + z_size (z1) <= z_addr (z2) + z_size (z2) + +predicate addr_in_zone (a:int, z:zone) = + z_addr (z) <= a and a < z_addr (z) + z_size (z) + +( --- offset --- ) +( Offset can be added to address to compute another address ) + +( type offset = (* offset ) int ) + +function rt_shift (addr:int, offset:int) : (* address ) int = addr + offset + +( We can get field information from its identifier : +type field : (* field ) int +) + +logic rt_foffset : (* field ) int -> ( offset ) int +logic rt_fsize : ( field ) int -> ( size ) int + +( TODO: we would prefer to have any format as result but why fail to +generate correct COQ files is the result is polymorphic ) +logic rt_fformat : ( name *) int -> int format + +(**) +(* === Zones === ) + +( Because we need to provide function such as [dzone_union] in the model, + we need more than simple [zone]. +TODO: [zones] might be defined as set of integers ? +) + +type zones + +logic zs_empty : zones +logic zs_singleton : zone -> zones +logic zs_union : zones, zones -> zones +logic zs_incl : zones, zones -> prop +logic zs_disj : zones, zones -> prop + +predicate zs_z_incl (z:zone, zs:zones) = zs_incl (zs_singleton (z), zs) +predicate zs_z_disj (z:zone, zs:zones) = zs_disj (zs_singleton (z), zs) + +( Some axioms but we need to add more (TODO if we don't use [set]) *) + +axiom zs_empty_incl : forall zs:zones. zs_incl (zs_empty, zs) +axiom zs_z_not_incl_empty : forall z:zone. + not zs_incl (zs_singleton (z), zs_empty) +axiom zs_incl_singleton : forall z1, z2:zone. + rt_incl (z1, z2) <-> zs_incl (zs_singleton(z1), zs_singleton(z2)) +axiom zs_incl_union_1 : forall z, z1, z2:zones. + zs_incl (z, z1) -> zs_incl (z, zs_union (z1, z2)) +axiom zs_incl_union_2 : forall z, z1, z2:zones. + zs_incl (z, z2) -> zs_incl (z, zs_union (z1, z2)) +axiom zs_incl_union_3: forall z, z1, z2 : zones. + zs_incl (z1, z) -> zs_incl (z2, z) -> zs_incl (zs_union (z1, z2), z) + + +axiom zs_disj_singleton : forall z1, z2:zone. + rt_disj (z1, z2) <-> zs_disj (zs_singleton(z1), zs_singleton(z2)) +axiom zs_incl_disj : forall z, zi, zd : zones. + zs_incl (zi, z) -> zs_disj (zd, z) -> zs_disj (zi, zd) + +(**) +(* === Values === ) + +( We define a value as a word of bits with a given size. +To know more about these [bits] interpretation, see the next section. ) + +type bits +logic bits_size : bits -> ( size ) int + +axiom bits_size_pos : forall b:bits. bits_size (b) >= 0 + +( [bits] elements are numbered from 0. +Precondition: [0 <= i < bits_size (b)] ) +logic nth_bit : bits, int -> bool + +axiom eq_bits : forall b1, b2:bits. forall sz: int. + bits_size (b1) = sz -> bits_size (b2) = sz -> + (forall i:int. 0 <= i < sz -> nth_bit (b1, i) = nth_bit (b2, i)) + <-> b1 = b2 + +( Test is zero. ) +predicate zero_bits (b:bits) = + forall i:int. 0 <= i < bits_size (b) -> nth_bit (b, i) = false + +( --- Extract parts of [bits] --- ) + +( Notice that [bits_part] is only defined when the zone defined by offset +and size is compatible with the initial bits size. +Precondition: [ offset+size <= bits_size (b) ] +) +logic bits_part : bits, ( offset ) int, ( size ) int -> bits + +axiom bits_part_size : forall b:bits. forall off, sz:int. + 0 <= off -> off + sz <= bits_size (b) -> + bits_size (bits_part (b, off, sz)) = sz + +axiom nth_bits_part : forall b:bits. forall off, i, sz:int. + 0 <= i < sz -> 0 <= off -> off + sz <= bits_size (b) -> + nth_bit (bits_part (b, off, sz), i) = nth_bit (b, off+i) + +( --- Concatenation of [bits] --- ) + +logic bits_concat : bits, bits -> bits + +axiom bits_concat_size : forall b1, b2:bits. + bits_size (bits_concat (b1, b2)) = bits_size (b1) + bits_size (b2) + +axiom nth_bits_concat_l : forall b1, b2: bits. forall i:int. + 0 <= i < bits_size (b1) -> + nth_bit (bits_concat (b1, b2), i) = nth_bit (b1, i) + +axiom nth_bits_concat_r : forall b1, b2: bits. forall i:int. + forall sz1, sz2:int. sz1 = bits_size (b1) -> sz2 = bits_size (b2) -> + sz1 <= i < sz1 + sz2 -> + nth_bit (bits_concat (b1, b2), i) = nth_bit (b2, i - sz1) + +( --- Write parts of [bits] --- ) + +( Notice that [wr_bits_part] is only defined when the zone defined by offset +and size of the second bits size is compatible with the initial bits size. +Precondition: [offset + size2 <= size1]. ) +logic wr_bits_part : bits, ( offset *) int, bits -> bits + +axiom wr_bits_part_size : forall b, bw:bits. forall o:int. + bits_size (wr_bits_part (b, o, bw)) = bits_size (b) + +axiom nth_wr_bits_part_1 : forall b, b': bits. forall off, i:int. + 0 <= i < off -> + nth_bit (wr_bits_part (b, off, b'), i) = nth_bit (b, i) + +axiom nth_wr_bits_part_2 : forall b, b': bits. forall off, i:int. + 0 <= off <= i < off+bits_size (b') -> + nth_bit (wr_bits_part (b, off, b'), i) = nth_bit (b', i - off) + +axiom nth_wr_bits_part_3 : forall b, b': bits. forall off, i:int. + 0 <= off + bits_size (b') <= i < bits_size (b) -> + nth_bit (wr_bits_part (b, off, b'), i) = nth_bit (b, i) + +(**) +(* === Interpretation to and from bits === ) + +( The [bits] defined above are used to represent the array of bits +as stored in the memory, so it depend on the memory architecture (endianness). +Moreover, the bits order is from the smaller bit address. +Example: if [b8] is [rt_to_bits uint8 1] we have: + [nth (b8, 7) = true] and [forall i. 0 <= i < 7 -> nth (b8, i) = false]. + but [b16 = rt_to_bits uint16 1] depend on the value of the + [little_endian] parameter. +Then finally, beware that [bits] is quite different from the usual bit +representation of a number. ) + + +( [rt_from_bits b f] is to interpret bits [b] to a typed value [f]. +The interpretation is valid only if the [bits] size match the size of the asked +format. +Precondition: [bits_size b = format_size f] ) +logic rt_from_bits : bits, 'a format -> 'a + +axiom rt_from_bits_format : forall b:bits. forall fmt: 'a format. + bits_size (b) = format_size (fmt) -> + is_in_format (fmt, rt_from_bits (b, fmt)) + +( [rt_to_bits] build the [bits] representation of a typed value. +This function is supposed to take care of the endianness because it should +return the bit vector stored in the memory from the smaller address to the +bigger one. +Precondition: [is_in_format f v]. +) +logic rt_to_bits : 'a format, 'a -> bits + +axiom rt_to_bits_size : forall fmt: 'a format. forall x: 'a + [bits_size (rt_to_bits (fmt, x))]. + bits_size (rt_to_bits (fmt, x)) = format_size (fmt) + +axiom rt_to_bits_from_bits : forall fmt:'a format. forall b:bits + [rt_to_bits (fmt, rt_from_bits (b, fmt))]. + bits_size (b) = format_size (fmt) -> + rt_to_bits (fmt, rt_from_bits (b, fmt)) = b + +axiom rt_from_bits_to_bits :forall fmt: 'a format. forall v:'a + [rt_from_bits (rt_to_bits (fmt, v), fmt)]. + is_in_format (fmt, v) -> + rt_from_bits (rt_to_bits (fmt, v), fmt) = v + +(---------------------------------------------------------------------------) +( --- Interpretation of integer --- ) + +( Be careful that this is not true for any format ! +For structures, for instance, the bits of padding can be anything +and still have the same interpretation... +But we know that the representation is unique for [int format] ) +axiom same_int_val_same_bits : forall b1, b2:bits. forall fmt: int format. + bits_size (b1) = format_size (fmt) -> + bits_size (b2) = format_size (fmt) -> + rt_from_bits (b1, fmt) = rt_from_bits (b2, fmt) -> b1 = b2 + +axiom rt_to_bits_zero : forall fmt: int format. + forall b:bits. b = rt_to_bits (fmt, 0) -> zero_bits (b) + +axiom rt_from_bits_zero : forall b:bits. forall fmt: int format. + zero_bits (b) -> rt_from_bits (b, fmt) = 0 + +( --- [bits] to and from [bool farray] in order to use [bits.why] --- *) + +(** [mbyte_to_bbits] only takes 8 bits from the memory representation, + and revert them to get a traditional binary representation. *) +logic mbyte_to_bbits : bits -> bool farray + +axiom mbyte_to_bbits_def : forall b:bits. bits_size (b) = 8 -> + forall i:int. 0 <= i < 8 -> + access (mbyte_to_bbits (b), i) = nth_bit (b, 7 - i) + +(** [nth_mbyte k b] returns the k-th byte of [b] ) +logic nth_mbyte : int, bits -> bits + +axiom nth_mbyte_size : forall b:bits. forall k:int. + bits_size (nth_mbyte (k, b)) = 8 + +axiom nth_byte_def : forall b:bits. + forall k:int. 0 <= 8 (k+1) <= bits_size (b) -> + forall i:int. 0 <= i < 8 -> + nth_bit (nth_mbyte (k, b), i) = nth_bit (b, 8 * k + i) + +function nth_byte (k:int, b:bits) : bool farray = + mbyte_to_bbits (nth_mbyte (k, b)) + +(----------------------------------------------------------------------------) +(** Interpretation of memory bits from and to binary representation *) + +logic little_endian : -> prop + +(** [concat_bytes w b] : [b] is a byte (8 bits) + to be added at the right of [w] word. ) + +logic concat_bytes : bool farray, bool farray -> bool farray + +axiom concat_bytes_left : forall w, b: bool farray. forall i:int. + 8 <= i -> access (concat_bytes (w, b), i) = access (w, i-8) + +axiom concat_bytes_right : forall w, b: bool farray. forall i:int. + 0 <= i < 8 -> access (concat_bytes (w, b), i) = access (b, i) + +(----------------------------------------------------------------------------*) +(** Some definitions related to binary representation (should be in data.why) ) + +logic uint_of_bits : int, bool farray -> int +logic sint_of_bits: int, bool farray -> int +function cint_of_bits (fmt:int format, b:bool farray) : int = + ite (signed_format (fmt), + sint_of_bits (format_size (fmt) - 1, b), + uint_of_bits (format_size (fmt) - 1, b)) + +logic bits_of_sint: int, int -> bool farray +logic bits_of_uint: int, int -> bool farray +function bits_of_cint (fmt: int format, x: int) : bool farray = + ite (signed_format (fmt), + bits_of_sint (format_size (fmt) - 1, x), + bits_of_uint (format_size (fmt) - 1, x)) + +(----------------------------------------------------------------------------*) +(** From memory to binary ) + +logic mbits_to_bbits : bits -> bool farray + +axiom mb8_to_bbits : forall b:bits. bits_size (b) = 8 -> + mbits_to_bbits (b) = nth_byte (0, b) + +axiom little_mb16_to_bbits : forall b:bits. bits_size (b) = 16 -> + little_endian -> + mbits_to_bbits (b) = concat_bytes (nth_byte (1, b), nth_byte (0, b)) + +axiom big_mb16_to_bbits : forall b:bits. bits_size (b) = 16 -> + not little_endian -> + mbits_to_bbits (b) = concat_bytes (nth_byte (0, b), nth_byte (1, b)) + +axiom little_mb32_to_bbits : forall b:bits. bits_size (b) = 32 -> + little_endian -> + mbits_to_bbits (b) = concat_bytes (concat_bytes ( + concat_bytes (nth_byte (3, b), + nth_byte (2, b)), + nth_byte (1, b)), + nth_byte (0, b)) + +axiom big_mb32_to_bbits : forall b:bits. bits_size (b) = 32 -> + not little_endian -> + mbits_to_bbits (b) = concat_bytes (concat_bytes ( + concat_bytes (nth_byte (0, b), + nth_byte (1, b)), + nth_byte (2, b)), + nth_byte (3, b)) + +axiom rt_int_from_bits : forall b:bits. forall fmt: int format. + rt_from_bits (b, fmt) = cint_of_bits (fmt, mbits_to_bbits (b)) + +(----------------------------------------------------------------------------*) +(** From binary to memory *) + +(** Build the 8 bits to store in the memory from the nth byte of binary +representation. ) +logic bbits_to_mbyte : int, bool farray -> bits + +axiom bbits_to_mbyte_size : forall b:bool farray. forall k:int. + bits_size (bbits_to_mbyte (k, b)) = 8 + +axiom bbits_to_mbyte_def : forall b:bool farray. forall k, i:int. + 0 <= i < 8 -> + nth_bit (bbits_to_mbyte (k, b), i) = access (b, 8k + 7-i) + +(** [bbits_to_mbits n b] use b[(n-1)..0] so gives n bits. *) +logic bbits_to_mbits : int, bool farray -> bits + +axiom bbits_to_mb8 : forall b:bool farray. + bbits_to_mbits (8, b) = bbits_to_mbyte (0, b) + +axiom bbits_to_little_mb16 : forall b:bool farray. + little_endian -> + bbits_to_mbits (16, b) = bits_concat (bbits_to_mbyte (0, b), + bbits_to_mbyte (1, b)) + +axiom bbits_to_big_mb16 : forall b:bool farray. + not little_endian -> + bbits_to_mbits (16, b) = bits_concat (bbits_to_mbyte (1, b), + bbits_to_mbyte (0, b)) + +axiom bbits_to_little_mb32 : forall b:bool farray. + little_endian -> + bbits_to_mbits (32, b) = bits_concat (bbits_to_mbyte (0, b), + bits_concat (bbits_to_mbyte (1, b), + bits_concat (bbits_to_mbyte (2, b), + bbits_to_mbyte (3, b)))) + +axiom bbits_to_not_mb32 : forall b:bool farray. + not little_endian -> + bbits_to_mbits (32, b) = bits_concat (bbits_to_mbyte (3, b), + bits_concat (bbits_to_mbyte (2, b), + bits_concat (bbits_to_mbyte (1, b), + bbits_to_mbyte (0, b)))) + +axiom rt_int_to_bits : forall x:int. forall fmt: int format. + rt_to_bits (fmt, x) = + bbits_to_mbits (format_size (fmt), bits_of_cint (fmt, x)) + +(**) +(* --- Memory --- ) + +( The memory is an abstract object that can be seen as a list of bits, +but we also assume that it stores information about the allocation table, +ie. it can provide the allocated zone which contains a given address. +) + +( from addresses to values. ) +type memory + +( allocation information. *) +type memalloc + +(**) +(* --- Allocation management --- ) + +( --- valid zone --- ) + +( a zone is valid when it is allocated in the memory, +ie. we can read/write in it. ) + +logic rt_valid : memalloc, zone -> prop + +axiom incl_valid : forall m:memalloc. forall z, z':zone. + rt_incl (z', z) -> rt_valid (m, z) -> rt_valid (m, z') + +axiom disj_valid : forall m:memalloc. forall z,z':zone [rt_disj (z, z')]. + rt_valid (m, z) -> not rt_valid (m, z') -> rt_disj (z, z') + +( --- base --- ) + +( [rt_zbase] returns the allocated zone in which the address is. +Notice that it returns a valid zone only is the address is allocated. ) +logic rt_zbase : memalloc, ( address ) int -> zone + +function rt_abase (m:memalloc, addr:int) : ( address ) int = + z_addr (rt_zbase (m, addr)) + +( TODO: check the meaning of that in ACSL and then add axioms ) +logic rt_block_length : memalloc, ( address ) int -> ( size ) int + + +( --- allocation --- ) + +( the [rt_alloc] function takes the size of the zone that we want to allocate, +and it returns a base address, and a new memory in which the zone is allocated. +Notice that at the moment, we assume that there is enough memory, +so that the allocation never fails. +) + +( Because we cannot use pairs in WHY, we have to define : ) +type mz ( = (memalloc * address) ) +logic mem_of_mz : mz -> memalloc +logic addr_of_mz : mz -> ( address ) int + +( Pre : size > 0 ) +logic rt_alloc : memalloc, ( size ) int -> mz + +function alloc_zone (m:memalloc, sz:int) : zone = + rt_zone (addr_of_mz (rt_alloc (m, sz)), sz) + +axiom alloc_is_base : forall m:memalloc. forall sz:int. + let mz = rt_alloc (m, sz) in + rt_zbase (mem_of_mz (mz), addr_of_mz (mz)) = alloc_zone (m, sz) + +( Of course, a new allocated zone is valid ) +axiom valid_alloc : forall m:memalloc. forall sz:int. + let mz = rt_alloc (m, sz) in + rt_valid (mem_of_mz (mz), alloc_zone (m, sz)) + +( The zone is not valid before having been allocated. ) +axiom not_valid_before_alloc: forall m:memalloc. forall sz:int. + not rt_valid (m, alloc_zone (m, sz)) + +( A previously allocated zone is still the same after a new allocation. ) +axiom alloc_keep_valid: forall m:memalloc. forall sz:int. forall z:zone. + rt_valid (m, z) -> + let mz = rt_alloc (m, sz) in rt_valid (mem_of_mz (mz), z) + +( All the zones that were invalid before the allocation and that are disjoint +from the newly allocation zone stays invalid. ) +axiom alloc_keep_invalid: forall m:memalloc. forall sz:int. forall z:zone. + let mz = rt_alloc (m, sz) in + rt_valid (mem_of_mz (mz), z) -> + rt_disj (alloc_zone (m, sz), z) -> + rt_valid (m, z) + +( --- free --- ) + +logic rt_free : memalloc, ( address ) int -> memalloc + +axiom not_valid_after_free : forall m:memalloc. forall addr:int. + forall z:zone. z = rt_zbase (m, addr) -> + addr = z_addr (z) -> not rt_valid (rt_free (m, addr), z) + +( This might be a lemma : *) +axiom valid_free_disj : forall m:memalloc. forall z, z':zone. + rt_valid (rt_free (m, z_addr (z)), z') <-> rt_disj (z, z') + + +(**) +(* --- Program objects --- ) + +( Program variables are also indexed by [int]s : + +type name = (* name ) int +) + + +(* We can find the address of a variable from its name in a given memory. +We could have returned a [option address] but it is much more complicated +to write functions. Instead of that, we assume that this function can return +an invalid address when the variable is not allocated +(for instance, a negative one). +) +logic rt_vaddr : memalloc, ( name ) int -> ( address ) int + +( TODO: we would prefer to have any format as result but WHY fails to +generate correct COQ files if the result is polymorphic ) +( logic rt_vformat : (* name ) int -> int format ) + +(* We would like to have : + function rt_vsize (v:int) : (* size ) int = format_size (rt_vformat (v)) +but it is not possible at the moment because of the limitation of [rt_vformat] +) +logic rt_vsize : (* name ) int -> ( size ) int +( axiom rt_vformat_vsize : forall v:int. + format_size (rt_vformat (v)) = rt_vsize (v) ) + +function rt_vzone (ma:memalloc, var:int) : zone = + rt_zone (rt_vaddr (ma, var), rt_vsize (var)) + +( Global variables always have the same zone, and are always valid ) +logic rt_global : ( name ) int -> prop + +axiom rt_global_vaddr : forall v:int. rt_global (v) -> + forall ma, ma':memalloc. rt_vaddr (ma, v) = rt_vaddr (ma', v) + +axiom rt_global_valid : forall ma:memalloc. forall v:int. + rt_global (v) -> + forall ma, ma':memalloc [rt_valid (ma, rt_vzone (ma', v))]. + rt_valid (ma, rt_vzone (ma', v)) + +( In a given memory, different variables have disjoint zones. ) +axiom vzone_disj : forall ma:memalloc. forall v1, v2:int. + v1 <> v2 -> + let z1 = rt_vzone (ma, v1) in + let z2 = rt_vzone (ma, v2) in + rt_valid (ma, z1) -> rt_valid (ma, z2) -> rt_disj (z1, z2) + +logic rt_valloc : memalloc, ( name ) int -> memalloc + +( TODO: put this as a definition ? ) +axiom rt_valloc_mem : forall ma:memalloc. forall var:int. + rt_valloc (ma, var) = mem_of_mz (rt_alloc (ma, rt_vsize (var))) + +axiom rt_valloc_addr : forall ma:memalloc. forall var:int. + forall ma':memalloc. ma' = rt_valloc (ma, var) -> + forall mz:mz. mz = rt_alloc (ma, rt_vsize (var)) -> + rt_vaddr (ma', var) = addr_of_mz (mz) + +axiom vzone_valloc_neq : forall ma:memalloc. forall v1, v2:int. + forall ma':memalloc. ma' = rt_valloc (ma, v1) -> + v1 <> v2 -> rt_vzone (ma', v2) = rt_vzone (ma, v2) + +(---------------------------) + +function rt_vfree (ma:memalloc, var:int) : memalloc = + rt_free (ma, rt_vaddr (ma, var)) + +( +axiom vfree_not_valid : forall ma:memalloc. forall v:int. + not (rt_valid (rt_vfree (ma, v), rt_vzone (ma, v))) + +axiom vfree_valid_neq : forall ma:memalloc. forall v1, v2:int. + v1 <> v2 -> rt_valid (ma, rt_vzone (ma, v1)) -> + rt_valid (rt_vfree (ma, v2), rt_vzone (ma, v1)) +) + +( lemma ) +axiom rt_vaddr_vfree : forall ma:memalloc. forall v1, v2:int. + v1 <> v2 -> rt_vaddr (rt_vfree (ma, v1), v2) = rt_vaddr (ma, v2) + +( lemma ) +( +axiom rt_vsize_vfree : forall ma:memalloc. forall v1, v2:int. + v1 <> v2 -> rt_vsize (rt_vfree (ma, v1), v2) = rt_vsize (ma, v2) +*) + +axiom addr_base : forall m:memalloc. forall v:int. + rt_abase (m, rt_vaddr (m, v)) = rt_vaddr (m, v) + + +(**) +(* === R/W in the memory === ) + +logic rt_load : memory, zone -> bits + +( Precondition: [z_size (zone) = bits_size (bits)] ) +logic rt_store : memory, ( address *) int, bits -> memory + +axiom load_store_same : forall m:memory. forall a:int. + forall z:zone. forall v:bits + [ rt_load(rt_store(m,a,v),z) ]. + z = rt_zone (a, bits_size (v)) -> + rt_load (rt_store (m, a, v), z) = v + +axiom load_store_disj : forall m: memory. forall a: int. + forall z:zone. forall v:bits + [ rt_load(rt_store(m,a,v),z) ]. + rt_disj ( rt_zone (a, bits_size(v)) , z ) -> + rt_load ( rt_store (m, a, v), z ) = rt_load(m, z) + +axiom load_store_incl_part : forall m: memory. + forall a:int. forall z1, z2 : zone. forall v:bits. + z2 = rt_zone (a, bits_size (v)) -> rt_incl (z1, z2) -> + rt_load (rt_store (m, a, v), z1) + = bits_part (v, z_addr (z1) - a, z_size (z1)) + +(** Write [v] at address [a], and load [z2] zone, + when writed zone [z1] included in [z2]. ) +axiom load_incl_part_store : forall m: memory. + forall z1, z2 : zone. forall v:bits. + forall a:int. z1 = rt_zone (a, bits_size (v)) -> + forall off : int. off = a - z_addr (z2) -> + rt_incl (z1, z2) -> + rt_load (rt_store (m, a, v), z2) + = wr_bits_part (rt_load (m, z2), off, v) + +axiom rt_load_size : forall m:memory. forall z:zone. + bits_size (rt_load (m, z)) = z_size (z) + +( +axiom rt_load_var_in_format : forall ma:memalloc. forall mb:memory. + forall v : int. + let fmt = rt_vformat (v) in + let bits = rt_load (mb, rt_vzone (ma, v)) in + let x = rt_from_bits (bits, fmt) in + is_in_format (fmt, x) +) + +axiom bits_part_rt_load : forall z, z':zone. forall a', off, sz:int. + a' = z_addr (z) + off -> + z' = rt_zone (a', sz) -> + rt_incl (z', z) -> + forall m:memory. rt_load (m, z') = bits_part (rt_load (m, z), off, sz) + +( --- eq mem --- ) + +axiom rt_same_mem : forall m1, m2:memory. + (forall z:zone. rt_load (m1, z) = rt_load (m2, z)) -> m1 = m2 + +( --- is_havoc --- ) + +logic rt_havoc : memory, zone -> memory + +( [rt_is_havoc] is used to compare 2 memory states. +It is valid when for each zone that is valid in [memalloc], +either it is included in the excluded [zones], +or the value of the zone is the same in both memory. *) + +predicate rt_is_havoc (ma:memalloc, m1:memory, zs:zones, m2:memory) = + forall z:zone. rt_valid (ma, z) -> zs_z_disj (z, zs) -> + rt_load (m1, z) = rt_load (m2, z) + +axiom rt_havoc_is_havoc : forall ma:memalloc. forall m:memory. + forall zs:zones. forall z:zone. zs_z_incl (z, zs) -> + rt_is_havoc (ma, m, zs, rt_havoc (m, z)) + +(**) +(* === Relation with DataLib === ) + +( --- pointer vs address --- ) + + +logic rt_addr_format : int format + +( IMPORTANT TODO: this should be generated according to the configuration !!!) +( axiom rt_addr_format_size : format_size (rt_addr_format) = 32 ) + +axiom rt_vaddr_format : forall ma: memalloc. forall v:int. + is_in_format (rt_addr_format, rt_vaddr (ma, v)) + +( ----------------------------------- ) +( --- logic value vs memory value --- ) + +( For each [struct] type, a format is defined automatically in the why file. +logic Cfmt_str: data farray format +It means that the result of [rt_from_bits (x, Cfmt_str)] is a [data farray] +which is the coded type for structures in logic. We still have to use +[encode/decode] functions to transform the [data] into real typed values. ) + +( --- bits_part vs access --- ) + +axiom bits_part_vs_access : forall bs: bits. + forall fs : data farray format. + forall f : int. forall off, sz:int. + off = rt_foffset (f) -> sz = rt_fsize (f) -> + rt_from_bits (bits_part (bs, off, sz), rt_fformat (f)) + = decode (int_format, access (rt_from_bits (bs, fs), f)) + +( --- wr_bits_part vs update --- ) + +( because the function [rt_fformat : ( field ) int -> 'a format ] +is not usable in COQ files, we have to generate this axiom in caml +for each field : + +axiom wr_bits_part_vs_update : forall bs, bx: bits. + forall fs : data farray format. forall fx : 'x format. + forall f : int. bits_size (bx) = rt_fsize (f) -> rt_fformat (f) = fx -> + rt_from_bits (wr_bits_part (bs, rt_foffset (f), bx), fs) + = update (rt_from_bits (bs, fs), f, encode (fx, rt_from_bits (bx, fx))) +) + + +(~~~~~~~~) +( ==== Pointer Arithmetic ==== ) +logic rt_addr_lt: int (address), int (address) -> prop +logic rt_addr_le: int (address), int (address) -> prop +logic rt_addr_lt_bool: int (address), int (address) -> bool +logic rt_addr_le_bool: int (address), int (address) -> bool +logic rt_addr_minus : int (address), int (address) -> int +logic rt_addr_eq: int (address), int (address) -> prop +logic rt_addr_eq_bool: int (address), int (address) -> bool + + + + + +( ~ End of runtime.why *) +(**) +(========================================================================) +(* Helper Lemmas for Runtime Model ) +(------------------------------------------------------------------------) + +( This file contains some lemmas that can be proved using the definitions +given in [runtime.why]. It is used to build a COQ file in order to check the +proofs, and then it can be used to help the ATP. +*) + +(**) +(* About zones : ) + +axiom rt_disj_sym : forall z1, z2:zone. + rt_disj (z1, z2) <-> rt_disj (z2, z1) + +axiom rt_disj_shift : forall addr:int. forall i, j, sz:int. + sz > 0 -> i <> j -> + rt_disj (rt_zone (rt_shift (addr, isz), sz), + rt_zone (rt_shift (addr, jsz), sz)) + +axiom vzone_of_zone : forall ma:memalloc. forall v, a, sz:int. + a = rt_vaddr (ma, v) -> sz = rt_vsize (v) -> + rt_zone (a, sz) = rt_vzone (ma, v) + +( +axiom rt_vsize_of_format : forall ma:memalloc. forall v:int [rt_vsize (ma, v)]. + rt_valid (ma, rt_vzone (ma, v)) -> + rt_vsize (ma, v) = format_size (rt_vformat (v)) +*) +(**) +(* About bits : ) + +axiom bits_part_full : forall v:bits. forall sz:int. + sz = bits_size (v) -> bits_part (v, 0, sz) = v + +axiom bits_part_of_bits_part : forall b:bits. forall o1, o2, sz1, sz2 : int. + 0 <= o1 -> o1 + sz1 <= bits_size (b) -> + 0 <= o2 -> o2 + sz2 <= sz1 -> + bits_part (bits_part (b, o1, sz1), o2, sz2) = bits_part (b, o1+o2, sz2) + +axiom eq_bits_split : forall b1, b2:bits. forall sz:int. + bits_size (b1) = sz -> bits_size (b2) = sz -> + forall sz1, sz2:int. sz1 >= 0 -> sz2 >= 0 -> sz1 + sz2 = sz -> + bits_part (b1, 0, sz1) = bits_part (b2, 0, sz1) -> + bits_part (b1, sz1, sz2) = bits_part (b2, sz1, sz2) -> + b1 = b2 + +axiom wr_bits_part_all : forall v, v':bits. + bits_size(v) = bits_size(v') -> wr_bits_part (v, 0, v') = v' + +axiom wr_bits_part_concat : + forall b, b':bits. + forall sz1, sz2, sz3:int. 0 <= sz1 -> sz2 = bits_size (b') -> 0 <= sz3 -> + sz1 + sz2 + sz3 = bits_size (b) -> + wr_bits_part (b, sz1, b') = + bits_concat (bits_part (b, 0, sz1), + bits_concat (b', bits_part (b, sz1+sz2, sz3))) + +( R/W in the same bit part and included in the valid zone *) +axiom wr_bits_part_same : forall b1, b2: bits. forall off: int. + 0 <= off -> off + bits_size (b2) <= bits_size (b1) -> + bits_part (wr_bits_part (b1, off, b2), off, bits_size (b2)) = b2 + +axiom wr_bits_part_disj : + forall b, b1: bits. forall off2, off1: int. forall sz, sz1, sz2:int. + sz = bits_size (b) -> sz1 = bits_size (b1) -> + 0 <= off1 -> off1 + sz1 <= sz -> + 0 <= off2 -> off2 + sz2 <= sz -> + off2 + sz2 <= off1 or off1 + sz1 <= off2 -> + bits_part (wr_bits_part (b, off1, b1), off2, sz2) = bits_part (b, off2, sz2) + +(**) +(* About rt_from_bits/rt_to_bits : ) + +( 0 is 0 in any integer format. ) +axiom rt_z_from_bits_to_bits_zero: forall fmt, fmt': int format. + rt_from_bits (rt_to_bits (fmt, 0), fmt') = 0 + +axiom bits_part_zero : forall b, b':bits. forall off, sz: int. + 0 <= off -> off + sz <= bits_size (b) -> b' = bits_part (b, off, sz) -> + zero_bits (b) -> zero_bits (b') + +axiom rw_same_var : forall m:memory. forall ma:memalloc. + forall v:int. forall val: bits + [rt_load (rt_store (m, rt_vaddr (ma, v), val), rt_vzone (ma, v))]. + bits_size (val) = rt_vsize (v) -> + rt_load (rt_store (m, rt_vaddr (ma, v), val), rt_vzone (ma, v)) = val + +axiom rw_disj_var : forall ma:memalloc. forall m:memory. forall v1, v2: int. + forall z1, z2: zone. forall b:bits + [rt_load (rt_store (m, rt_vaddr (ma, v2), b), rt_vzone (ma, v1))] . + v1 <> v2 -> z1 = rt_vzone (ma, v1) -> z2 = rt_vzone (ma, v2) -> + rt_valid (ma, z1) -> rt_valid (ma, z2) -> rt_vsize (v2) = bits_size (b) -> + rt_load (rt_store (m, rt_vaddr (ma, v2), b), z1) = rt_load(m, z1) + +axiom store_concat : + forall m, m1: memory. forall a: int. forall b1, b2: bits. + forall sz1:int. sz1 = bits_size (b1) -> m1 = rt_store (m, a, b1) -> + rt_store (m1, a + sz1, b2) = rt_store (m, a, bits_concat (b1, b2)) + +axiom store_disj_commut : forall m:memory. + forall a1, a2: int. forall b1, b2: bits. + rt_disj (rt_zone (a1, bits_size (b1)), rt_zone (a2, bits_size (b2))) -> + rt_store (rt_store (m, a1, b1), a2, b2) += rt_store (rt_store (m, a2, b2), a1, b1) + +( +axiom mbyte_to_bbits_to_mbyte : forall b:bool farray. + n_bits_eq (7, mbyte_to_bbits (bbits_to_mbyte (0, b)), b) + +axiom bbits_to_mbyte_to_bbits : forall b:bits. bits_size (b) = 8 -> + bbits_to_mbyte (0, mbyte_to_bbits (b)) = b + +axiom nth_byte_0 : forall b:bits. bits_size (b) = 8 -> + nth_byte (0, b) = mbyte_to_bbits (b) + +axiom bits_concat_nth_byte_left : forall b1, b2: bits. forall k:int. + 8(k+1) <= bits_size (b1) -> + nth_byte (k, bits_concat (b1, b2)) = nth_byte (k, b1) + +axiom bits_concat_nth_byte_right : forall b1, b2: bits. forall k1, k:int. + bits_size (b1) = 8 k1 -> k1 <= k -> 8((k-k1)+1) <= bits_size (b2) -> + nth_byte (k, bits_concat (b1, b2)) = nth_byte (k-k1, b2) +) +(**) +(* About allocation : ) + +axiom not_valid_before_valloc : forall ma:memalloc. forall v:int + ( [ not rt_valid (ma, rt_vzone (ma', v)) ] ) . + forall ma':memalloc. ma' = rt_valloc (ma, v) -> + not rt_valid (ma, rt_vzone (ma', v)) + +axiom valid_valloc : forall ma:memalloc. forall v:int. forall ma':memalloc + [ rt_valid (ma', rt_vzone (ma', v)) ]. + ma' = rt_valloc (ma, v) -> rt_valid (ma', rt_vzone (ma', v)) + +axiom valloc_keep_valid_zone : forall ma:memalloc. forall v:int. + forall ma':memalloc. ma' = rt_valloc (ma, v) -> + forall z:zone. rt_valid (ma, z) -> rt_valid (ma', z) + +axiom valloc_keep_valid_disj_zone : forall ma:memalloc. forall v:int. + forall ma':memalloc. ma' = rt_valloc (ma, v) -> + forall z:zone. rt_disj (rt_vzone (ma', v), z) -> + rt_valid (ma', z) -> rt_valid (ma, z) + +axiom valloc_keep_invalid_zone : forall ma:memalloc. forall v:int. + forall ma':memalloc. ma' = rt_valloc (ma, v) -> + forall z:zone. rt_disj (rt_vzone (ma', v), z) -> + not rt_valid (ma, z) -> not rt_valid (ma', z) + +axiom valloc_keep_invalid_zone_rev : forall ma:memalloc. forall v:int. + forall ma':memalloc. ma' = rt_valloc (ma, v) -> + forall z:zone. rt_disj (rt_vzone (ma', v), z) -> + not rt_valid (ma', z) -> not rt_valid (ma, z) + +( TODO hyp v<>v1 shouldn't be needed since v1 is valid before alloc v ) +axiom valloc_keep_valid_var : forall ma:memalloc. forall v1, v:int. + forall ma':memalloc. ma' = rt_valloc (ma, v) -> v <> v1 -> + rt_valid (ma, rt_vzone (ma, v1)) -> rt_valid (ma', rt_vzone (ma', v1)) + +axiom valloc_keep_vaddr : forall ma:memalloc. forall v1, v:int. + forall ma':memalloc. ma' = rt_valloc (ma, v) -> v <> v1 -> + rt_vaddr (ma', v1) = rt_vaddr (ma, v1) + +( +axiom valloc_keep_vsize : forall ma:memalloc. forall v1, v, sz:int. + forall ma':memalloc. ma' = rt_valloc (ma, v, sz) -> v <> v1 -> + rt_vsize (ma', v1) = rt_vsize (ma, v1) +) + +axiom valloc_keep_vzone : forall ma:memalloc. forall v1, v:int. + forall ma':memalloc. ma' = rt_valloc (ma, v) -> v <> v1 -> + rt_vzone (ma', v1) = rt_vzone (ma, v1) + +axiom vzone_vfree : forall ma:memalloc. forall v1, v2: int. + forall ma':memalloc. ma' = rt_vfree (ma, v1) -> v1 <> v2 -> + rt_vzone (ma', v2) = rt_vzone (ma, v2) + +axiom not_valid_after_vfree : forall ma:memalloc. forall v:int. + forall ma':memalloc. ma' = rt_vfree (ma, v) -> + forall z:zone. z = rt_vzone (ma, v) -> + not (rt_valid (ma', z)) + + +axiom havoc_store: forall ma:memalloc. forall m1,m2:memory. forall zs:zones. + forall z:zone. forall x:bits. forall a:int. z = rt_zone (a, bits_size (x)) -> + rt_is_havoc (ma, m1, zs, m2) -> zs_z_incl (z, zs) -> + rt_is_havoc (ma, m1, zs, rt_store (m2, a, x)) + +axiom havoc_invalid : forall ma:memalloc. forall m1,m2:memory. forall zs:zones. + forall z:zone. forall x:bits. forall a:int. z = rt_zone (a, bits_size (x)) -> + rt_is_havoc (ma, m1, zs, m2) -> not rt_valid (ma, z) -> + rt_is_havoc (ma, m1, zs, rt_store (m2, a, x)) + +axiom same_bits_same_val : forall b1, b2:bits. forall fmt: 'a format. + b1 = b2 -> rt_from_bits (b1, fmt) = rt_from_bits (b2, fmt) + +axiom valid_vglob : forall v:int. rt_global (v) -> + forall ma, ma':memalloc. rt_valid (ma, rt_vzone (ma', v)) + +(~~~~~~~~~~~~~~~~~~~~~~~~) + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/store_ergo.why frama-c-20111001+nitrogen+dfsg/src/wp/share/store_ergo.why --- frama-c-20110201+carbon+dfsg/src/wp/share/store_ergo.why 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/store_ergo.why 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,1156 @@ +logic eq_unit : unit,unit -> prop + +logic neq_unit : unit,unit -> prop + +logic eq_bool : bool,bool -> prop + +logic neq_bool : bool,bool -> prop + +logic lt_int : int,int -> prop + +logic le_int : int,int -> prop + +logic gt_int : int,int -> prop + +logic ge_int : int,int -> prop + +logic eq_int : int,int -> prop + +logic neq_int : int,int -> prop + +logic add_int : int,int -> int + +logic sub_int : int,int -> int + +logic mul_int : int,int -> int + +logic neg_int : int -> int + +predicate zwf_zero(a:int,b:int) = ((0<=b) and (a<b)) + +logic bool_and : bool,bool -> bool + +logic bool_or : bool,bool -> bool + +logic bool_xor : bool,bool -> bool + +logic bool_not : bool -> bool + +axiom bool_and_def : (forall a:bool.(forall b:bool. +((bool_and(a,b)=true) <-> ((a=true) and (b=true))))) + +axiom bool_or_def : (forall a:bool.(forall b:bool. +((bool_or(a,b)=true) <-> ((a=true) or (b=true))))) + +axiom bool_xor_def : (forall a:bool.(forall b:bool. +((bool_xor(a,b)=true) <-> (a<>b)))) + +axiom bool_not_def : (forall a:bool. +((bool_not(a)=true) <-> (a=false))) + +logic ite : bool,'a1,'a1 -> 'a1 + +axiom ite_true : (forall x:'a1.(forall y:'a1. +(ite(true,x,y)=x))) + +axiom ite_false : (forall x:'a1.(forall y:'a1. +(ite(false,x,y)=y))) + +logic lt_int_bool : int,int -> bool + +logic le_int_bool : int,int -> bool + +logic gt_int_bool : int,int -> bool + +logic ge_int_bool : int,int -> bool + +logic eq_int_bool : int,int -> bool + +logic neq_int_bool : int,int -> bool + +axiom lt_int_bool_axiom : (forall x:int.(forall y:int. +((lt_int_bool(x,y)=true) <-> (x<y)))) + +axiom le_int_bool_axiom : (forall x:int.(forall y:int. +((le_int_bool(x,y)=true) <-> (x<=y)))) + +axiom gt_int_bool_axiom : (forall x:int.(forall y:int. +((gt_int_bool(x,y)=true) <-> (x>y)))) + +axiom ge_int_bool_axiom : (forall x:int.(forall y:int. +((ge_int_bool(x,y)=true) <-> (x>=y)))) + +axiom eq_int_bool_axiom : (forall x:int.(forall y:int. +((eq_int_bool(x,y)=true) <-> (x=y)))) + +axiom neq_int_bool_axiom : (forall x:int.(forall y:int. +((neq_int_bool(x,y)=true) <-> (x<>y)))) + +logic abs_int : int -> int + +axiom abs_int_pos : (forall x:int. +((x>=0) -> (abs_int(x)=x))) + +axiom abs_int_neg : (forall x:int. +((x<=0) -> (abs_int(x)=(-x)))) + +logic int_max : int,int -> int + +logic int_min : int,int -> int + +axiom int_max_is_ge : (forall x:int.(forall y:int. +((int_max(x,y)>=x) and (int_max(x,y)>=y)))) + +axiom int_max_is_some : (forall x:int.(forall y:int. +((int_max(x,y)=x) or (int_max(x,y)=y)))) + +axiom int_min_is_le : (forall x:int.(forall y:int. +((int_min(x,y)<=x) and (int_min(x,y)<=y)))) + +axiom int_min_is_some : (forall x:int.(forall y:int. +((int_min(x,y)=x) or (int_min(x,y)=y)))) + +logic lt_real : real,real -> prop + +logic le_real : real,real -> prop + +logic gt_real : real,real -> prop + +logic ge_real : real,real -> prop + +logic eq_real : real,real -> prop + +logic neq_real : real,real -> prop + +logic add_real : real,real -> real + +logic sub_real : real,real -> real + +logic mul_real : real,real -> real + +logic div_real : real,real -> real + +logic neg_real : real -> real + +logic real_of_int : int -> real + +axiom real_of_int_zero : (real_of_int(0)=0.0) + +axiom real_of_int_one : (real_of_int(1)=1.0) + +axiom real_of_int_add : (forall x:int.(forall y:int. +(real_of_int((x+y))=(real_of_int(x)+real_of_int(y))))) + +axiom real_of_int_sub : (forall x:int.(forall y:int. +(real_of_int((x-y))=(real_of_int(x)-real_of_int(y))))) + +logic truncate_real_to_int : real -> int + +axiom truncate_down_pos : (forall x:real. +((x>=0.0) -> ((real_of_int(truncate_real_to_int(x))<=x) and (x<real_of_int((truncate_real_to_int(x)+1)))))) + +axiom truncate_up_neg : (forall x:real. +((x<=0.0) -> ((real_of_int((truncate_real_to_int(x)-1))<x) and (x<=real_of_int(truncate_real_to_int(x)))))) + +logic floor_real_to_int : real -> int + +logic ceil_real_to_int : real -> int + +logic lt_real_bool : real,real -> bool + +logic le_real_bool : real,real -> bool + +logic gt_real_bool : real,real -> bool + +logic ge_real_bool : real,real -> bool + +logic eq_real_bool : real,real -> bool + +logic neq_real_bool : real,real -> bool + +axiom lt_real_bool_axiom : (forall x:real.(forall y:real. +((lt_real_bool(x,y)=true) <-> (x<y)))) + +axiom le_real_bool_axiom : (forall x:real.(forall y:real. +((le_real_bool(x,y)=true) <-> (x<=y)))) + +axiom gt_real_bool_axiom : (forall x:real.(forall y:real. +((gt_real_bool(x,y)=true) <-> (x>y)))) + +axiom ge_real_bool_axiom : (forall x:real.(forall y:real. +((ge_real_bool(x,y)=true) <-> (x>=y)))) + +axiom eq_real_bool_axiom : (forall x:real.(forall y:real. +((eq_real_bool(x,y)=true) <-> (x=y)))) + +axiom neq_real_bool_axiom : (forall x:real.(forall y:real. +((neq_real_bool(x,y)=true) <-> (x<>y)))) + +logic real_max : real,real -> real + +logic real_min : real,real -> real + +axiom real_max_is_ge : (forall x:real.(forall y:real. +((real_max(x,y)>=x) and (real_max(x,y)>=y)))) + +axiom real_max_is_some : (forall x:real.(forall y:real. +((real_max(x,y)=x) or (real_max(x,y)=y)))) + +axiom real_min_is_le : (forall x:real.(forall y:real. +((real_min(x,y)<=x) and (real_min(x,y)<=y)))) + +axiom real_min_is_some : (forall x:real.(forall y:real. +((real_min(x,y)=x) or (real_min(x,y)=y)))) + +function sqr_real(x:real) : real = (xx) + +logic sqrt_real : real -> real + +axiom sqrt_pos : (forall x:real. +((x>=0.0) -> (sqrt_real(x)>=0.0))) + +axiom sqrt_sqr : (forall x:real. +((x>=0.0) -> (sqr_real(sqrt_real(x))=x))) + +axiom sqr_sqrt : (forall x:real. +((x>=0.0) -> (sqrt_real((xx))=x))) + +logic pow_real : real,real -> real + +logic abs_real : real -> real + +axiom abs_real_pos : (forall x:real[abs_real(x)]. +((x>=0.0) -> (abs_real(x)=x))) + +axiom abs_real_neg : (forall x:real[abs_real(x)]. +((x<=0.0) -> (abs_real(x)=(-x)))) + +logic exp : real -> real + +logic log : real -> real + +logic log10 : real -> real + +axiom log_exp : (forall x:real. +(log(exp(x))=x)) + +axiom exp_log : (forall x:real. +((x>0.0) -> (exp(log(x))=x))) + +logic cos : real -> real + +logic sin : real -> real + +logic tan : real -> real + +logic pi : real + +logic cosh : real -> real + +logic sinh : real -> real + +logic tanh : real -> real + +logic acos : real -> real + +logic asin : real -> real + +logic atan : real -> real + +logic atan2 : real,real -> real + +logic hypot : real,real -> real + +axiom prod_pos : (forall x:real.(forall y:real. +((((x>0.0) and (y>0.0)) -> ((xy)>0.0)) and (((x<0.0) and (y<0.0)) -> ((xy)>0.0))))) + +axiom abs_minus : (forall x:real. +(abs_real((-x))=abs_real(x))) + + +logic access : 'a1 farray,int -> 'a1 + +logic update : 'a1 farray,int,'a1 -> 'a1 farray + +axiom access_update : (forall a:'a1 farray.(forall i:int.(forall v:'a1. +(a[i<-v][i]=v)))) + +axiom access_update_neq : (forall a:'a1 farray.(forall i:int.(forall j:int. +(forall v:'a1. +((i<>j) -> (a[i<-v][j]=a[j])))))) + +logic array_length : 'a1 farray -> int + +predicate sorted_array(t:int farray,i:int,j:int) = (forall k1:int. +(forall k2:int. +((((i<=k1) and (k1<=k2)) and (k2<=j)) -> (t[k1]<=t[k2])))) + +predicate exchange(a1:'a1 farray,a2:'a1 farray,i:int,j:int) = ((array_length(a1)=array_length(a2)) and ((a1[i]=a2[j]) and ((a2[i]=a1[j]) and ( +forall k:int. +(((k<>i) and (k<>j)) -> (a1[k]=a2[k])))))) + +logic permut : 'a1 farray,'a1 farray,int,int -> prop + +axiom permut_refl : (forall t:'a1 farray.(forall l:int.(forall u:int. +permut(t,t,l, +u)))) + +axiom permut_sym : (forall t1:'a1 farray.(forall t2:'a1 farray.(forall l:int. +(forall u:int.(permut(t1,t2,l,u) -> permut(t2,t1,l, +u)))))) + +axiom permut_trans : (forall t1:'a1 farray.(forall t2:'a1 farray. +(forall t3:'a1 farray.(forall l:int.(forall u:int.(permut(t1,t2,l, +u) -> (permut(t2,t3,l,u) -> permut(t1,t3,l, +u)))))))) + +axiom permut_exchange : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l:int.(forall u:int.(forall i:int.(forall j:int. +(((l<=i) and (i<=u)) -> (((l<=j) and (j<=u)) -> (exchange(a1,a2,i, +j) -> permut(a1,a2,l, +u)))))))))) + +axiom exchange_upd : (forall a:'a1 farray.(forall i:int.(forall j:int. +exchange(a,a[i<-a[j]][j<-a[i]],i, +j)))) + +axiom permut_weakening : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l1:int.(forall r1:int.(forall l2:int.(forall r2:int. +((((l1<=l2) and (l2<=r2)) and (r2<=r1)) -> (permut(a1,a2,l2,r2) -> permut(a1, +a2,l1, +r1))))))))) + +axiom permut_eq : (forall a1:'a1 farray.(forall a2:'a1 farray.(forall l:int. +(forall u:int.((l<=u) -> (permut(a1,a2,l,u) -> (forall i:int. +(((i<l) or (u<i)) -> (a2[i]=a1[i]))))))))) + +predicate permutation(a1:'a1 farray,a2:'a1 farray) = permut(a1,a2,0, +(array_length(a1)-1)) + +axiom array_length_update : (forall a:'a1 farray.(forall i:int.(forall v:'a1. +(array_length(a[i<-v])=array_length(a))))) + +axiom permut_array_length : (forall a1:'a1 farray.(forall a2:'a1 farray. +(forall l:int.(forall u:int.(permut(a1,a2,l, +u) -> (array_length(a1)=array_length(a2))))))) + +logic computer_div : int,int -> int + +logic computer_mod : int,int -> int + +logic math_div : int,int -> int + +logic math_mod : int,int -> int + +axiom math_div_mod : (forall x:int.(forall y:int. +((y<>0) -> (x=((ymath_div(x,y))+math_mod(x,y)))))) + +axiom math_mod_bound : (forall x:int.(forall y:int. +((y<>0) -> ((0<=math_mod(x,y)) and (math_mod(x,y)<abs_int(y)))))) + +axiom computer_div_mod : (forall x:int. +(forall y:int[computer_div(x,y),computer_mod(x,y)]. +((y<>0) -> (x=((ycomputer_div(x,y))+computer_mod(x,y)))))) + +axiom computer_div_bound : (forall x:int.(forall y:int. +(((x>=0) and (y>0)) -> ((0<=computer_div(x,y)) and (computer_div(x,y)<=x))))) + +axiom computer_mod_bound : (forall x:int.(forall y:int. +((y<>0) -> (abs_int(computer_mod(x,y))<abs_int(y))))) + +axiom computer_mod_sign_pos : (forall x:int.(forall y:int. +(((x>=0) and (y<>0)) -> (computer_mod(x,y)>=0)))) + +axiom computer_mod_sign_neg : (forall x:int.(forall y:int. +(((x<=0) and (y<>0)) -> (computer_mod(x,y)<=0)))) + +axiom computer_rounds_toward_zero : (forall x:int.(forall y:int. +((y<>0) -> (abs_int((computer_div(x,y)y))<=abs_int(x))))) + +logic dummy : int -> prop + +logic assigns : int -> prop + +axiom positive_computer_div_div : (forall x:int.(forall y:int. +((x>0) -> ((y>0) -> (computer_div(x,y)=math_div(x,y)))))) + +type 'a set + +logic empty : 'a1 set + +logic singleton : 'a1 -> 'a1 set + +logic range : int,int -> int set + +logic union : 'a1 set,'a1 set -> 'a1 set + +logic inter : 'a1 set,'a1 set -> 'a1 set + +logic plus_int : int set,int set -> int set + +logic subset : 'a1 set,'a1 set -> prop + +logic range_inf : int -> int set + +logic range_sup : int -> int set + +logic integers_set : int set + +logic equiv : 'a1 set,'a1 set -> prop + +logic member : 'a1,'a1 set -> prop + +axiom singleton_def : (forall x:'a1.member(x, +singleton(x))) + +axiom singleton_eq : (forall x:'a1.(forall y:'a1.(member(x, +singleton(y)) <-> (x=y)))) + +axiom union_member : (forall x:'a1.(forall s1:'a1 set. +(forall s2:'a1 set[member(x,union(s1,s2))].(member(x, +union(s1,s2)) <-> (member(x,s1) or member(x, +s2)))))) + +axiom union_of_empty : (forall x:'a1 set[union(x,empty)]. +(union(x,empty)=x)) + +axiom inter_of_empty : (forall x:'a1 set[inter(x,empty)]. +(inter(x,empty)=empty)) + +axiom union_comm : (forall x:'a1 set.(forall y:'a1 set. +(union(x,y)=union(y,x)))) + +axiom inter_comm : (forall x:'a1 set.(forall y:'a1 set. +(inter(x,y)=inter(y,x)))) + +axiom inter_member : (forall x:'a1.(forall s1:'a1 set. +(forall s2:'a1 set[member(x,inter(s1,s2))].(member(x, +inter(s1,s2)) <-> (member(x,s1) and member(x, +s2)))))) + +axiom plus_int_member_1 : (forall sa:int set.(forall sb:int set. +(forall a:int.(forall b:int[member((a+b),plus_int(sa,sb))].(member(a, +sa) -> (member(b,sb) -> member((a+b), +plus_int(sa,sb)))))))) + +axiom plus_int_member_2 : (forall sa:int set.(forall sb:int set. +(forall c:int.(member(c,plus_int(sa,sb)) -> (exists a:int.(exists b:int. +(member(a,sa) and (member(b, +sb) and (c=(a+b)))))))))) + +axiom subset_empty : (forall sa:'a1 set.subset(empty, +sa)) + +axiom subset_sym : (forall sa:'a1 set.subset(sa, +sa)) + +axiom subset_trans : (forall sa:'a1 set.(forall sb:'a1 set. +(forall sc:'a1 set.(subset(sa,sb) -> (subset(sb,sc) -> subset(sa, +sc)))))) + +axiom subset_def : (forall sa:'a1 set.(forall sb:'a1 set[subset(sa,sb)]. +((forall a:'a1.(member(a,sa) -> member(a,sb))) <-> subset(sa, +sb)))) + +axiom range_def : (forall i:int.(forall j:int.(forall k:int. +(((i<=k) and (k<=j)) <-> member(k, +range(i,j)))))) + +axiom range_def1 : (forall i:int.(forall j:int.(forall k:int. +(((i<=k) and (k<=j)) -> member(k, +range(i,j)))))) + +axiom range_def2 : (forall i:int.(forall j:int.(forall k:int.(member(k, +range(i,j)) -> ((i<=k) and (k<=j)))))) + +axiom range_inf_def : (forall i:int.(forall k:int.((i<=k) <-> member(k, +range_inf(i))))) + +axiom range_sup_def : (forall j:int.(forall k:int.((k<=j) <-> member(k, +range_sup(j))))) + +axiom integers_set_def : (forall k:int.((k>=0) <-> member(k, +integers_set))) + +axiom equiv_def : (forall s1:'a1 set.(forall s2:'a1 set[equiv(s1,s2)]. +(((forall a:'a1.(member(a,s1) -> member(a,s2))) and (forall b:'a1.(member(b, +s2) -> member(b,s1)))) <-> equiv(s1, +s2)))) + +axiom equiv_refl : (forall s:'a1 set.equiv(s, +s)) + +axiom equiv_sym : (forall s1:'a1 set.(forall s2:'a1 set.(equiv(s1, +s2) -> equiv(s2, +s1)))) + +axiom equiv_trans : (forall s1:'a1 set.(forall s2:'a1 set.(forall s3:'a1 set. +(equiv(s1,s2) -> (equiv(s2,s3) -> equiv(s1, +s3)))))) + +logic as_uint8 : int -> int + +predicate is_uint8(x:int) = ((0<=x) and (x<256)) + +axiom as_uint8_def : (forall x:int. +is_uint8(as_uint8(x))) + +axiom as_uint8_involve : (forall x:int[as_uint8(as_uint8(x))]. +(as_uint8(as_uint8(x))=as_uint8(x))) + +axiom is_as_uint8 : (forall x:int[as_uint8(x)]. +(is_uint8(x) -> (as_uint8(x)=x))) + +logic as_sint8 : int -> int + +predicate is_sint8(x:int) = (((-128)<=x) and (x<128)) + +axiom as_sint8_def : (forall x:int. +is_sint8(as_sint8(x))) + +axiom as_sint8_involve : (forall x:int[as_sint8(as_sint8(x))]. +(as_sint8(as_sint8(x))=as_sint8(x))) + +axiom is_as_sint8 : (forall x:int[as_sint8(x)]. +(is_sint8(x) -> (as_sint8(x)=x))) + +logic as_uint16 : int -> int + +predicate is_uint16(x:int) = ((0<=x) and (x<65536)) + +axiom as_uint16_def : (forall x:int. +is_uint16(as_uint16(x))) + +axiom as_uint16_involve : (forall x:int[as_uint16(as_uint16(x))]. +(as_uint16(as_uint16(x))=as_uint16(x))) + +axiom is_as_uint16 : (forall x:int[as_uint16(x)]. +(is_uint16(x) -> (as_uint16(x)=x))) + +logic as_sint16 : int -> int + +predicate is_sint16(x:int) = (((-32768)<=x) and (x<32768)) + +axiom as_sint16_def : (forall x:int. +is_sint16(as_sint16(x))) + +axiom as_sint16_involve : (forall x:int[as_sint16(as_sint16(x))]. +(as_sint16(as_sint16(x))=as_sint16(x))) + +axiom is_as_sint16 : (forall x:int[as_sint16(x)]. +(is_sint16(x) -> (as_sint16(x)=x))) + +logic as_uint32 : int -> int + +predicate is_uint32(x:int) = ((0<=x) and (x<4294967296)) + +axiom as_uint32_def : (forall x:int. +is_uint32(as_uint32(x))) + +axiom as_uint32_involve : (forall x:int[as_uint32(as_uint32(x))]. +(as_uint32(as_uint32(x))=as_uint32(x))) + +axiom is_as_uint32 : (forall x:int[as_uint32(x)]. +(is_uint32(x) -> (as_uint32(x)=x))) + +logic as_sint32 : int -> int + +predicate is_sint32(x:int) = (((-2147483648)<=x) and (x<2147483648)) + +axiom as_sint32_def : (forall x:int. +is_sint32(as_sint32(x))) + +axiom as_sint32_involve : (forall x:int[as_sint32(as_sint32(x))]. +(as_sint32(as_sint32(x))=as_sint32(x))) + +axiom is_as_sint32 : (forall x:int[as_sint32(x)]. +(is_sint32(x) -> (as_sint32(x)=x))) + +logic as_uint64 : int -> int + +predicate is_uint64(x:int) = ((0<=x) and (x<18446744073709551616)) + +axiom as_uint64_def : (forall x:int. +is_uint64(as_uint64(x))) + +axiom as_uint64_involve : (forall x:int[as_uint64(as_uint64(x))]. +(as_uint64(as_uint64(x))=as_uint64(x))) + +axiom is_as_uint64 : (forall x:int[as_uint64(x)]. +(is_uint64(x) -> (as_uint64(x)=x))) + +logic as_sint64 : int -> int + +predicate is_sint64(x:int) = (((-9223372036854775808)<=x) and (x<9223372036854775808)) + +axiom as_sint64_def : (forall x:int. +is_sint64(as_sint64(x))) + +axiom as_sint64_involve : (forall x:int[as_sint64(as_sint64(x))]. +(as_sint64(as_sint64(x))=as_sint64(x))) + +axiom is_as_sint64 : (forall x:int[as_sint64(x)]. +(is_sint64(x) -> (as_sint64(x)=x))) + +logic as_float16 : real -> real + +logic is_float16 : real -> prop + +axiom as_float16_def : (forall x:real. +is_float16(as_float16(x))) + +axiom as_float16_involve : (forall x:real[as_float16(as_float16(x))]. +(as_float16(as_float16(x))=as_float16(x))) + +axiom is_as_float16 : (forall x:real[as_float16(x)]. +(is_float16(x) -> (as_float16(x)=x))) + +logic as_float32 : real -> real + +logic is_float32 : real -> prop + +axiom as_float32_def : (forall x:real. +is_float32(as_float32(x))) + +axiom as_float32_involve : (forall x:real[as_float32(as_float32(x))]. +(as_float32(as_float32(x))=as_float32(x))) + +axiom is_as_float32 : (forall x:real[as_float32(x)]. +(is_float32(x) -> (as_float32(x)=x))) + +logic as_float64 : real -> real + +logic is_float64 : real -> prop + +axiom as_float64_def : (forall x:real. +is_float64(as_float64(x))) + +axiom as_float64_involve : (forall x:real[as_float64(as_float64(x))]. +(as_float64(as_float64(x))=as_float64(x))) + +axiom is_as_float64 : (forall x:real[as_float64(x)]. +(is_float64(x) -> (as_float64(x)=x))) + +logic as_float128 : real -> real + +logic is_float128 : real -> prop + +axiom as_float128_def : (forall x:real. +is_float128(as_float128(x))) + +axiom as_float128_involve : (forall x:real[as_float128(as_float128(x))]. +(as_float128(as_float128(x))=as_float128(x))) + +axiom is_as_float128 : (forall x:real[as_float128(x)]. +(is_float128(x) -> (as_float128(x)=x))) + +type data + +logic data_of_uint8 : int -> data + +logic uint8_of_data : data -> int + +axiom is_uint8_of_data : (forall d:data[is_uint8(uint8_of_data(d))]. +is_uint8(uint8_of_data(d))) + +axiom uint8ofdata_dataofuint8 : (forall x:int[data_of_uint8(x)]. +(is_uint8(x) -> (uint8_of_data(data_of_uint8(x))=x))) + +logic data_of_sint8 : int -> data + +logic sint8_of_data : data -> int + +axiom is_sint8_of_data : (forall d:data[is_sint8(sint8_of_data(d))]. +is_sint8(sint8_of_data(d))) + +axiom sint8ofdata_dataofsint8 : (forall x:int[data_of_sint8(x)]. +(is_sint8(x) -> (sint8_of_data(data_of_sint8(x))=x))) + +logic data_of_uint16 : int -> data + +logic uint16_of_data : data -> int + +axiom is_uint16_of_data : (forall d:data[is_uint16(uint16_of_data(d))]. +is_uint16(uint16_of_data(d))) + +axiom uint16ofdata_dataofuint16 : (forall x:int[uint16_of_data(data_of_uint16(x))]. +(is_uint16(x) -> (uint16_of_data(data_of_uint16(x))=x))) + +logic data_of_sint16 : int -> data + +logic sint16_of_data : data -> int + +axiom is_sint16_of_data : (forall d:data[is_sint16(sint16_of_data(d))]. +is_sint16(sint16_of_data(d))) + +axiom sint16ofdata_dataofsint16 : (forall x:int[data_of_sint16(x)]. +(is_sint16(x) -> (sint16_of_data(data_of_sint16(x))=x))) + +logic data_of_uint32 : int -> data + +logic uint32_of_data : data -> int + +axiom is_uint32_of_data : (forall d:data[is_uint32(uint32_of_data(d))]. +is_uint32(uint32_of_data(d))) + +axiom uint32ofdata_dataofuint32 : (forall x:int[data_of_uint32(x)]. +(is_uint32(x) -> (uint32_of_data(data_of_uint32(x))=x))) + +logic data_of_sint32 : int -> data + +logic sint32_of_data : data -> int + +axiom is_sint32_of_data : (forall d:data[is_sint32(sint32_of_data(d))]. +is_sint32(sint32_of_data(d))) + +axiom sint32ofdata_dataofsint32 : (forall x:int[data_of_sint32(x)]. +(is_sint32(x) -> (sint32_of_data(data_of_sint32(x))=x))) + +logic data_of_uint64 : int -> data + +logic uint64_of_data : data -> int + +axiom is_uint64_of_data : (forall d:data[is_uint64(uint64_of_data(d))]. +is_uint64(uint64_of_data(d))) + +axiom uint64ofdata_dataofuint64 : (forall x:int[data_of_uint64(x)]. +(is_uint64(x) -> (uint64_of_data(data_of_uint64(x))=x))) + +logic data_of_sint64 : int -> data + +logic sint64_of_data : data -> int + +axiom is_sint64_of_data : (forall d:data[is_sint64(sint64_of_data(d))]. +is_sint64(sint64_of_data(d))) + +axiom sint64ofdata_dataofsint64 : (forall x:int[data_of_sint64(x)]. +(is_sint64(x) -> (sint64_of_data(data_of_sint64(x))=x))) + +logic data_of_float16 : real -> data + +logic float16_of_data : data -> real + +axiom is_float16_of_data : (forall d:data[is_float16(float16_of_data(d))]. +is_float16(float16_of_data(d))) + +axiom float16ofdata_dataoffloat16 : (forall x:real[data_of_float16(x)]. +(is_float16(x) -> (float16_of_data(data_of_float16(x))=x))) + +logic data_of_float32 : real -> data + +logic float32_of_data : data -> real + +axiom is_float32_of_data : (forall d:data[is_float32(float32_of_data(d))]. +is_float32(float32_of_data(d))) + +axiom float32ofdata_dataoffloat32 : (forall x:real[data_of_float32(x)]. +(is_float32(x) -> (float32_of_data(data_of_float32(x))=x))) + +logic data_of_float64 : real -> data + +logic float64_of_data : data -> real + +axiom is_float64_of_data : (forall d:data[is_float64(float64_of_data(d))]. +is_float64(float64_of_data(d))) + +axiom float64ofdata_dataoffloat64 : (forall x:real[data_of_float64(x)]. +(is_float64(x) -> (float64_of_data(data_of_float64(x))=x))) + +logic data_of_float128 : real -> data + +logic float128_of_data : data -> real + +axiom is_float128_of_data : (forall d:data[is_float128(float128_of_data(d))]. +is_float128(float128_of_data(d))) + +axiom float128ofdata_dataoffloat128 : (forall x:real[data_of_float128(x)]. +(is_float128(x) -> (float128_of_data(data_of_float128(x))=x))) + +logic set_range_index : 'a1 farray,int set,int -> 'a1 farray + +axiom set_range_def : (forall t:'a1 farray.(forall rg:int set.(forall k:int. +(forall i:int[set_range_index(t,rg,k)[i]].((not member(i, +rg)) -> (set_range_index(t,rg,k)[i]=t[i])))))) + +logic bnot : int -> int + +logic band : int,int -> int + +logic bor : int,int -> int + +logic bxor : int,int -> int + +logic lshift : int,int -> int + +logic rshift : int,int -> int + +logic int_not : int -> int + +logic int_and : int,int -> int + +logic int_or : int,int -> int + +logic int_xor : int,int -> int + +logic int_lsh : int,int -> int + +logic int_rshs : int,int -> int + +logic int_rshu : int,int -> int + +logic addr : int,int -> int + +logic offset : int -> int + +logic base : int -> int + +axiom addr_def : (forall a:int.(forall b:int.(forall d:int. +((addr(b,d)=a) -> ((base(a)=b) and (offset(a)=d)))))) + +axiom addr_id : (forall p:int[addr(base(p),offset(p))]. +(addr(base(p),offset(p))=p)) + +logic minus_addr : int,int -> int + +axiom minus_addr_def : (forall a:int.(forall b:int. +((base(a)=base(b)) -> (minus_addr(a,b)=(offset(a)-offset(b)))))) + +predicate addr_lt(a:int,b:int) = ((base(a)=base(b)) and (offset(a)<offset(b))) + +function addr_lt_bool(a:int,b:int) : bool = bool_and(eq_int_bool(base(a),base(b)),lt_int_bool(offset(a),offset(b))) + +predicate addr_le(a:int,b:int) = ((base(a)=base(b)) and (offset(a)<=offset(b))) + +function addr_le_bool(a:int,b:int) : bool = bool_and(eq_int_bool(base(a),base(b)),le_int_bool(offset(a),offset(b))) + +predicate addr_eq(a:int,b:int) = ((base(a)=base(b)) and (offset(a)=offset(b))) + +function addr_eq_bool(a:int,b:int) : bool = bool_and(eq_int_bool(base(a),base(b)),eq_int_bool(offset(a),offset(b))) + +axiom cmp_null : (forall p:int[addr_eq(p,0)].((p=0) <-> addr_eq(p, +0))) + +axiom cmp_null_bool : (forall p:int[addr_eq_bool(p,0)]. +((p=0) <-> (addr_eq_bool(p,0)=true))) + +axiom cmp_null_not : (forall p:int.((p<>0) <-> (not addr_eq(p, +0)))) + +axiom cmp_null_bool_not : (forall p:int[addr_eq_bool(p,0)]. +((p<>0) <-> (addr_eq_bool(p,0)=false))) + +logic addr_of_data : data -> int + +logic data_of_addr : int -> data + +axiom addrofdata_dataofaddr : (forall p:int[data_of_addr(p)]. +(addr_of_data(data_of_addr(p))=p)) + +predicate valid(ta:int farray,p:int,n:int) = ((n>0) -> ((0<=offset(p)) and ((offset(p)+n)<=ta[base(p)]))) + +logic global : int farray -> prop + +logic is_fresh : data farray,int farray,int -> prop + +axiom fresh : (forall mem:data farray.(forall ta:int farray. +(forall ta':int farray.(forall x:int.(forall p:int. +(forall n:int[valid(ta',p,n),is_fresh(mem,ta,x)].(is_fresh(mem,ta, +x) -> ((ta[x]=0) -> ((ta[base(p)]=ta'[base(p)]) -> (valid(ta',p, +n) -> (forall d:int.(forall sz:int. +(addr(x,d)<>p))))))))))))) + +axiom fresh_access : (forall mem:data farray.(forall mem':data farray. +(forall ta:int farray.(forall ta':int farray.(forall b:int.(forall p:int. +(forall n:int[is_fresh(mem,ta,b),valid(ta',p,n),addr_of_data(mem'[p])]. +(is_fresh(mem,ta,b) -> ((ta[b]=0) -> (valid(ta',p, +n) -> ((ta[base(p)]=ta'[base(p)]) -> ((mem[p]=mem'[p]) -> (forall d:int. +(addr(b,d)<>addr_of_data(mem'[p]))))))))))))))) + +function addr_shift(p:int,dofs:int) : int = addr(base(p),(offset(p)+dofs)) + +predicate separated_on_addr(p:int,p':int,n1:int,n2:int) = ((base(p)=base(p')) -> (((offset(p)+n1)<=offset(p')) or (offset(p)>=(offset(p')+n2)))) + +type zone + +logic zrange : int,int,int -> zone + +logic zempty : zone + +logic zunion : zone,zone -> zone + +logic included : zone,zone -> prop + +logic is_havoc : int farray,data farray,zone,data farray -> prop + +logic is_block : zone -> prop + +axiom is_block_zrange : (forall x:int.(forall ofs:int.(forall len:int. +((len>0) -> is_block(zrange(x,ofs,len)))))) + +axiom is_not_block_zempty : (not is_block(zempty)) + +function zrange_of_addr(p:int) : zone = zrange(base(p),offset(p),1) + +function zrange_of_addr_range(p:int,dofs:int,n:int) : zone = zrange(base(p),(offset(p)+dofs),n) + +logic separated : zone,zone -> prop + +axiom sep_zrange : (forall b:int.(forall b':int.(forall d:int.(forall d':int. +(forall sz:int.(forall sz':int[separated(zrange(b,d,sz),zrange(b',d',sz'))]. +(separated(zrange(b,d,sz),zrange(b',d',sz')) <-> separated_on_addr(addr(b,d), +addr(b',d'),sz, +sz')))))))) + +axiom separated_sym : (forall z:zone.(forall z':zone.(separated(z, +z') -> separated(z', +z)))) + +axiom sep_empty : (forall z:zone.separated(zempty, +z)) + +axiom sep_union : (forall z:zone.(forall z':zone. +(forall r:zone[separated(z,zunion(z',r))].(separated(z, +zunion(z',r)) <-> (separated(z,z') and separated(z, +r)))))) + +axiom left_empty : (forall z:zone. +(zunion(z,zempty)=z)) + +axiom right_empty : (forall z:zone. +(zunion(zempty,z)=z)) + +axiom union_same : (forall z:zone. +(zunion(z,z)=z)) + +axiom union_sym : (forall z:zone.(forall z':zone. +(zunion(z,z')=zunion(z',z)))) + +axiom union_assoc : (forall z:zone.(forall r:zone.(forall s:zone. +(zunion(zunion(z,r),s)=zunion(z,zunion(r,s)))))) + +axiom inc_range_range : (forall b:int.(forall d:int.(forall sz:int. +(forall b':int.(forall d':int. +(forall sz':int[included(zrange(b,d,sz),zrange(b',d',sz'))]. +(included(zrange(b,d,sz), +zrange(b',d',sz')) <-> ((d<=(d+sz)) -> ((b=b') and ((d'<=d) and ((d+sz)<=(d'+sz')))))))))))) + +axiom inc_empty : (forall z:zone.included(zempty, +z)) + +axiom inc_same : (forall z:zone.included(z, +z)) + +axiom inc_range_empty : (forall b:int.(forall d:int. +(forall sz:int[included(zrange(b,d,sz),zempty)].(included(zrange(b,d,sz), +zempty) <-> (b>(b+sz)))))) + +axiom inc_union_right : (forall z:zone.(forall r:zone. +(forall s:zone[included(z,zunion(r,s))].((included(z,r) or included(z, +s)) -> included(z, +zunion(r,s)))))) + +axiom inc_union_left : (forall s:zone.(forall z:zone. +(forall z':zone[included(zunion(s,z'),z)].(included(s,z) -> (included(z', +z) -> included(zunion(s,z'), +z)))))) + +logic access_range : data farray,zone -> data + +logic update_range : data farray,zone,data -> data farray + +axiom access_update_range_same : (forall m:data farray.(forall z:zone. +(forall d:data. +(is_block(z) -> (access_range(update_range(m,z,d),z)=d))))) + +axiom access_update_range_sep : (forall m:data farray.(forall v:data. +(forall z:zone.(forall z':zone[access_range(update_range(m,z,v),z')]. +(is_block(z) -> (is_block(z') -> (separated(z, +z') -> (access_range(update_range(m,z,v),z')=access_range(m,z'))))))))) + +axiom access_range_update_addr_sep : (forall m:data farray.(forall v:data. +(forall z:zone.(forall p:int[access_range(m[p<-v],z)]. +(is_block(z) -> (separated(z, +zrange_of_addr(p)) -> (access_range(m[p<-v],z)=access_range(m,z)))))))) + +axiom access_update_range_addr_sep : (forall m:data farray.(forall v:data. +(forall z:zone.(forall p:int[update_range(m,z,v)[p]]. +(is_block(z) -> (separated(z, +zrange_of_addr(p)) -> (update_range(m,z,v)[p]=m[p]))))))) + +axiom access_update_sep : (forall m:data farray.(forall v:data.(forall p:int. +(forall q:int[m[p<-v][q]].(separated(zrange_of_addr(p), +zrange_of_addr(q)) -> (m[p<-v][q]=m[q])))))) + +logic update_havoc : data farray,zone,data -> data farray + +axiom load_havoc : (forall m:data farray.(forall v:data.(forall z:zone. +(forall p:int[update_havoc(m,z,v)[p]].(separated(z, +zrange_of_addr(p)) -> (update_havoc(m,z,v)[p]=m[p])))))) + +axiom load_is_havoc : (forall alloc:int farray.(forall mem:data farray. +(forall mem':data farray.(forall p:int. +(forall z:zone[mem[p],is_havoc(alloc,mem,z,mem')]. +(included(zrange_of_addr(p),z) -> (is_havoc(alloc,mem,z, +mem') -> (mem'[p]=mem[p])))))))) + +logic is_assignable : int farray,zone,zone -> prop + +axiom is_assignable_range_free : (forall alloc:int farray.(forall p:int. +(forall z:zone[is_assignable(alloc,zrange_of_addr(p),z)]. +((alloc[base(p)]=0) -> is_assignable(alloc,zrange_of_addr(p), +z))))) + +axiom is_assignable_included : (forall alloc:int farray.(forall z:zone. +(forall z':zone[is_assignable(alloc,z,z')].(included(z, +z') -> is_assignable(alloc,z, +z'))))) + +axiom same_havoc : (forall alloc:int farray.(forall mem:data farray. +(forall z:zone.is_havoc(alloc,mem,z, +mem)))) + +axiom havoc_sym : (forall alloc:int farray.(forall m1:data farray. +(forall m2:data farray.(forall z:zone.(is_havoc(alloc,m2,z, +m1) -> is_havoc(alloc,m1,z, +m2)))))) + +axiom store_havoc : (forall alloc:int farray.(forall mem:data farray. +(forall mem':data farray.(forall p:int.(forall v:data. +(forall z:zone[is_havoc(alloc,mem,z,mem'[p<-v])].(is_assignable(alloc, +zrange_of_addr(p),z) -> (is_havoc(alloc,mem,z,mem') -> is_havoc(alloc,mem,z, +mem'[p<-v]))))))))) + +axiom store_havoc_havoc : (forall alloc:int farray.(forall mem:data farray. +(forall mem':data farray.(forall v:data.(forall z':zone. +(forall z:zone[is_havoc(alloc,mem,z,update_havoc(mem',z',v))]. +(is_assignable(alloc,z',z) -> (is_havoc(alloc,mem,z,mem') -> is_havoc(alloc, +mem,z, +update_havoc(mem',z',v)))))))))) + +axiom store_range_havoc : (forall alloc:int farray.(forall mem:data farray. +(forall mem':data farray.(forall v:data.(forall z':zone. +(forall z:zone[is_havoc(alloc,mem,z,update_range(mem',z',v))]. +(is_block(z') -> (is_assignable(alloc,z',z) -> (is_havoc(alloc,mem,z, +mem') -> is_havoc(alloc,mem,z, +update_range(mem',z',v))))))))))) + +axiom addr_base : (forall b:int.(forall d:int. +(base(addr(b,d))=b))) + +axiom addr_offset : (forall b:int.(forall d:int. +(offset(addr(b,d))=d))) + +axiom base_sep : (forall b:int.(forall b':int.(forall d:int.(forall d':int. +((b<>b') -> (addr(b,d)<>addr(b',d'))))))) + +axiom addr_inj1 : (forall b:int.(forall b':int.(forall d:int. +((b=b') <-> (addr(b,d)=addr(b',d)))))) + +axiom addr_inj2 : (forall b:int.(forall d:int.(forall d':int. +((d=d') <-> (addr(b,d)=addr(b,d')))))) + +axiom addr_lt_eq : (forall a:int[addr_lt(a,a)].(not addr_lt(a, +a))) + +axiom addr_le_eq : (forall a:int[addr_le(a,a)].addr_le(a, +a)) + +axiom minus_pos_lt : (forall a:int.(forall b:int[addr_lt(a,b)]. +((base(a)=base(b)) -> (((offset(b)-offset(a))>0) -> addr_lt(a, +b))))) + +axiom minus_pos_le : (forall a:int.(forall b:int[addr_le(a,b)]. +((base(a)=base(b)) -> (((offset(b)-offset(a))>=0) -> addr_le(a, +b))))) + +axiom addr_lt_le : (forall a:int.(forall b:int[addr_le(a,b)].(addr_lt(a, +b) -> addr_le(a, +b)))) + +axiom havoc_union_update_left : (forall alloc:int farray. +(forall m:data farray.(forall m':data farray.(forall p:int.(forall v:data. +(forall asgns:zone.(is_havoc(alloc,m,zunion(zrange_of_addr(p),asgns), +m') -> is_havoc(alloc,m,zunion(zrange_of_addr(p),asgns), +m'[p<-v])))))))) + +axiom havoc_union_update_right : (forall alloc:int farray. +(forall m:data farray.(forall m':data farray.(forall p:int.(forall v:data. +(forall z:zone.(forall asgns:zone.(included(zrange_of_addr(p), +asgns) -> (is_havoc(alloc,m,zunion(z,asgns),m') -> is_havoc(alloc,m, +zunion(z,asgns), +m'[p<-v])))))))))) + +axiom havoc_union_update_range_left : (forall alloc:int farray. +(forall m:data farray.(forall m':data farray.(forall v:data.(forall p:int. +(forall asgns:zone.(is_havoc(alloc,m,zunion(zrange_of_addr(p),asgns), +m') -> is_havoc(alloc,m,zunion(zrange_of_addr(p),asgns), +update_range(m',zrange_of_addr(p),v))))))))) + +axiom havoc_union_update_range_right : (forall alloc:int farray. +(forall m:data farray.(forall m':data farray.(forall v:data.(forall p:int. +(forall z:zone.(forall asgns:zone.(included(zrange_of_addr(p), +asgns) -> (is_havoc(alloc,m,zunion(z,asgns),m') -> is_havoc(alloc,m, +zunion(z,asgns), +update_range(m',zrange_of_addr(p),v))))))))))) + +axiom inc_union_union : (forall z0:zone.(forall z1:zone.(forall z2:zone. +(forall z3:zone.(included(z0,z2) -> (included(z1, +z3) -> included(zunion(z0,z1), +zunion(z2,z3)))))))) + +axiom inc_sub_zone : (forall z:zone.(forall z':zone. +included(zunion(zunion(z,z'),zunion(z',z)), +zunion(z',z)))) + +axiom inc_permut_union : (forall z:zone.(forall z':zone.(forall r:zone. +included(zunion(zunion(z,z'),r), +zunion(zunion(z,r),z'))))) + +axiom inc_permut2 : (forall z:zone.(forall s:zone.(forall r:zone. +included(zunion(zunion(zunion(zunion(z,s),r),r),s), +zunion(zunion(z,r),s))))) + +axiom union_assoc2 : (forall z:zone.(forall z':zone. +(zunion(z,zunion(z,z'))=zunion(z,z')))) + +axiom addr_shift_0 : (forall p:int[addr_shift(p,0)]. +(addr_shift(p,0)=p)) + +axiom addr_shift_shift : (forall p:int.(forall d:int. +(forall d':int[addr_shift(addr_shift(p,d),d')]. +(addr_shift(addr_shift(p,d),d')=addr_shift(p,(d+d')))))) + +axiom valid_elt : (forall ta:int farray.(forall p:int.(forall i:int. +(forall n:int.((n>0) -> (valid(ta,p,n) -> ((0<=i) -> (((i+1)<=n) -> valid(ta, +addr_shift(p,i), +1))))))))) + +axiom separated_on_addr_sym : (forall p:int.(forall q:int.(forall n:int. +(forall m:int.(separated_on_addr(p,q,n,m) -> separated_on_addr(q,p,m, +n)))))) + +axiom separated_on_addr_inc : (forall b:int.(forall d:int.(forall d':int. +(forall sz:int.(forall sz':int.(forall b1:int.(forall d1:int.(forall sz1:int. +(separated_on_addr(addr(b1,d1),addr(b,d),sz1, +sz) -> ((d<=d') -> (((d'+sz')<=(d+sz)) -> separated_on_addr(addr(b1,d1), +addr(b,d'),sz1, +sz')))))))))))) + +axiom separated_inc : (forall b:int.(forall d:int.(forall d':int. +(forall sz:int.(forall sz':int.(forall b1:int.(forall d1:int.(forall sz1:int. +(separated(zrange(b1,d1,sz1), +zrange(b,d,sz)) -> ((d<=d') -> (((d'+sz')<=(d+sz)) -> separated(zrange(b1,d1,sz1), +zrange(b,d',sz'))))))))))))) + +axiom separated_one_elt : (forall n:int.(forall m:int.(forall b:int. +(forall d:int.(forall sz:int.(forall b':int.(forall d':int.(forall sz':int. +((0<n) -> ((0<m) -> (separated(zrange(b,d,(szn)), +zrange(b',d',(sz'm))) -> (forall i:int.(forall j:int. +((0<=i) -> ((0<=j) -> ((((d+i)+sz)<=(d+(szn))) -> ((((d'+j)+sz')<=(d'+(sz'm))) -> separated(zrange(b,(d+i),sz), +zrange(b',(d'+j),sz'))))))))))))))))))) + +axiom store_pointer : (forall x:int.(forall ofs:int.(forall y:int. +(forall ofs':int.(separated_on_addr(addr(x,ofs),addr(y,ofs'),1, +1) or (addr(x,ofs)=addr(y,ofs'))))))) + + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/store_model.v frama-c-20111001+nitrogen+dfsg/src/wp/share/store_model.v --- frama-c-20110201+carbon+dfsg/src/wp/share/store_model.v 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/store_model.v 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,1785 @@ +(* This file was originally generated by why. + It can be modified; only the generated parts will be overwritten. ) +Require Import Reals. Require Import wp. + +(Why logic) Definition bool_and : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_or : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_xor : bool -> bool -> bool. +Admitted. + +(Why logic) Definition bool_not : bool -> bool. +Admitted. + +(Why axiom) Lemma bool_and_def : + (forall (a:bool), + (forall (b:bool), ((bool_and a b) = true <-> a = true /\ b = true))). +Admitted. + +(Why axiom) Lemma bool_or_def : + (forall (a:bool), + (forall (b:bool), ((bool_or a b) = true <-> a = true \/ b = true))). +Admitted. + +(Why axiom) Lemma bool_xor_def : + (forall (a:bool), (forall (b:bool), ((bool_xor a b) = true <-> ~(a = b)))). +Admitted. + +(Why axiom) Lemma bool_not_def : + (forall (a:bool), ((bool_not a) = true <-> a = false)). +Admitted. + +(Why logic) Definition ite : forall (A1:Set), bool -> A1 -> A1 -> A1. +Admitted. +Implicit Arguments ite. + +(Why axiom) Lemma ite_true : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), (if_then_else true x y) = x)). +Admitted. + +(Why axiom) Lemma ite_false : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), (if_then_else false x y) = y)). +Admitted. + +(Why logic) Definition lt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition le_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition gt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition ge_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition eq_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition neq_int_bool : Z -> Z -> bool. +Admitted. + +(Why axiom) Lemma lt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((lt_int_bool x y) = true <-> x < y))). +Admitted. + +(Why axiom) Lemma le_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((le_int_bool x y) = true <-> x <= y))). +Admitted. + +(Why axiom) Lemma gt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((gt_int_bool x y) = true <-> x > y))). +Admitted. + +(Why axiom) Lemma ge_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((ge_int_bool x y) = true <-> x >= y))). +Admitted. + +(Why axiom) Lemma eq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((eq_int_bool x y) = true <-> x = y))). +Admitted. + +(Why axiom) Lemma neq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((neq_int_bool x y) = true <-> x <> y))). +Admitted. + +(Why logic) Definition abs_int : Z -> Z. +Admitted. + +(Why axiom) Lemma abs_int_pos : + (forall (x:Z), (x >= 0 -> (abs_int x) = x)). +Admitted. + +(Why axiom) Lemma abs_int_neg : + (forall (x:Z), (x <= 0 -> (abs_int x) = (Zopp x))). +Admitted. + +(Why logic) Definition int_max : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_min : Z -> Z -> Z. +Admitted. + +(Why axiom) Lemma int_max_is_ge : + (forall (x:Z), (forall (y:Z), (int_max x y) >= x /\ (int_max x y) >= y)). +Admitted. + +(Why axiom) Lemma int_max_is_some : + (forall (x:Z), (forall (y:Z), (int_max x y) = x \/ (int_max x y) = y)). +Admitted. + +(Why axiom) Lemma int_min_is_le : + (forall (x:Z), (forall (y:Z), (int_min x y) <= x /\ (int_min x y) <= y)). +Admitted. + +(Why axiom) Lemma int_min_is_some : + (forall (x:Z), (forall (y:Z), (int_min x y) = x \/ (int_min x y) = y)). +Admitted. + +(Why logic) Definition lt_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition le_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition gt_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition ge_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition eq_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition neq_real : R -> R -> Prop. +Admitted. + +(Why logic) Definition add_real : R -> R -> R. +Admitted. + +(Why logic) Definition sub_real : R -> R -> R. +Admitted. + +(Why logic) Definition mul_real : R -> R -> R. +Admitted. + +(Why logic) Definition div_real : R -> R -> R. +Admitted. + +(Why logic) Definition neg_real : R -> R. +Admitted. + +(Why logic) Definition real_of_int : Z -> R. +Admitted. + +(Why axiom) Lemma real_of_int_zero : (eq (IZR 0) (0)%R). +Admitted. + +(Why axiom) Lemma real_of_int_one : (eq (IZR 1) (1)%R). +Admitted. + +(Why axiom) Lemma real_of_int_add : + (forall (x:Z), (forall (y:Z), (eq (IZR (x + y)) (Rplus (IZR x) (IZR y))))). +Admitted. + +(Why axiom) Lemma real_of_int_sub : + (forall (x:Z), (forall (y:Z), (eq (IZR (x - y)) (Rminus (IZR x) (IZR y))))). +Admitted. + +(Why logic) Definition truncate_real_to_int : R -> Z. +Admitted. + +(Why axiom) Lemma truncate_down_pos : + (forall (x:R), + ((Rge x (0)%R) -> (Rle (IZR (truncate_real_to_int x)) x) /\ + (Rlt x (IZR ((truncate_real_to_int x) + 1))))). +Admitted. + +(Why axiom) Lemma truncate_up_neg : + (forall (x:R), + ((Rle x (0)%R) -> (Rlt (IZR ((truncate_real_to_int x) - 1)) x) /\ + (Rle x (IZR (truncate_real_to_int x))))). +Admitted. + +(Why logic) Definition floor_real_to_int : R -> Z. +Admitted. + +(Why logic) Definition ceil_real_to_int : R -> Z. +Admitted. + +(Why logic) Definition lt_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition le_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition gt_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition ge_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition eq_real_bool : R -> R -> bool. +Admitted. + +(Why logic) Definition neq_real_bool : R -> R -> bool. +Admitted. + +(Why axiom) Lemma lt_real_bool_axiom : + (forall (x:R), (forall (y:R), ((lt_real_bool x y) = true <-> (Rlt x y)))). +Admitted. + +(Why axiom) Lemma le_real_bool_axiom : + (forall (x:R), (forall (y:R), ((le_real_bool x y) = true <-> (Rle x y)))). +Admitted. + +(Why axiom) Lemma gt_real_bool_axiom : + (forall (x:R), (forall (y:R), ((gt_real_bool x y) = true <-> (Rgt x y)))). +Admitted. + +(Why axiom) Lemma ge_real_bool_axiom : + (forall (x:R), (forall (y:R), ((ge_real_bool x y) = true <-> (Rge x y)))). +Admitted. + +(Why axiom) Lemma eq_real_bool_axiom : + (forall (x:R), (forall (y:R), ((eq_real_bool x y) = true <-> (eq x y)))). +Admitted. + +(Why axiom) Lemma neq_real_bool_axiom : + (forall (x:R), (forall (y:R), ((neq_real_bool x y) = true <-> ~(eq x y)))). +Admitted. + +(Why logic) Definition real_max : R -> R -> R. +Admitted. + +(Why logic) Definition real_min : R -> R -> R. +Admitted. + +(Why axiom) Lemma real_max_is_ge : + (forall (x:R), + (forall (y:R), (Rge (real_max x y) x) /\ (Rge (real_max x y) y))). +Admitted. + +(Why axiom) Lemma real_max_is_some : + (forall (x:R), + (forall (y:R), (eq (real_max x y) x) \/ (eq (real_max x y) y))). +Admitted. + +(Why axiom) Lemma real_min_is_le : + (forall (x:R), + (forall (y:R), (Rle (real_min x y) x) /\ (Rle (real_min x y) y))). +Admitted. + +(Why axiom) Lemma real_min_is_some : + (forall (x:R), + (forall (y:R), (eq (real_min x y) x) \/ (eq (real_min x y) y))). +Admitted. + +(Why function) Definition sqr_real (x:R) := (Rmult x x). + +(Why logic) Definition sqrt_real : R -> R. +Admitted. + +(Why axiom) Lemma sqrt_pos : + (forall (x:R), ((Rge x (0)%R) -> (Rge (sqrt x) (0)%R))). +Admitted. + +(Why axiom) Lemma sqrt_sqr : + (forall (x:R), ((Rge x (0)%R) -> (eq (sqr_real (sqrt x)) x))). +Admitted. + +(Why axiom) Lemma sqr_sqrt : + (forall (x:R), ((Rge x (0)%R) -> (eq (sqrt (Rmult x x)) x))). +Admitted. + +(Why logic) Definition pow_real : R -> R -> R. +Admitted. + +(Why logic) Definition abs_real : R -> R. +Admitted. + +(Why axiom) Lemma abs_real_pos : + (forall (x:R), ((Rge x (0)%R) -> (eq (Rabs x) x))). +Admitted. + +(Why axiom) Lemma abs_real_neg : + (forall (x:R), ((Rle x (0)%R) -> (eq (Rabs x) (Ropp x)))). +Admitted. + +(Why logic) Definition exp : R -> R. +Admitted. + +(Why logic) Definition log : R -> R. +Admitted. + +(Why logic) Definition log10 : R -> R. +Admitted. + +(Why axiom) Lemma log_exp : (forall (x:R), (eq (log (exp x)) x)). +Admitted. + +(Why axiom) Lemma exp_log : + (forall (x:R), ((Rgt x (0)%R) -> (eq (exp (log x)) x))). +Admitted. + +(Why logic) Definition cos : R -> R. +Admitted. + +(Why logic) Definition sin : R -> R. +Admitted. + +(Why logic) Definition tan : R -> R. +Admitted. + +(Why logic) Definition pi : R. +Admitted. + +(Why logic) Definition cosh : R -> R. +Admitted. + +(Why logic) Definition sinh : R -> R. +Admitted. + +(Why logic) Definition tanh : R -> R. +Admitted. + +(Why logic) Definition acos : R -> R. +Admitted. + +(Why logic) Definition asin : R -> R. +Admitted. + +(Why logic) Definition atan : R -> R. +Admitted. + +(Why logic) Definition atan2 : R -> R -> R. +Admitted. + +(Why logic) Definition hypot : R -> R -> R. +Admitted. + +(Why axiom) Lemma prod_pos : + (forall (x:R), + (forall (y:R), + (((Rgt x (0)%R) /\ (Rgt y (0)%R) -> (Rgt (Rmult x y) (0)%R))) /\ + (((Rlt x (0)%R) /\ (Rlt y (0)%R) -> (Rgt (Rmult x y) (0)%R))))). +Admitted. + +(Why axiom) Lemma abs_minus : + (forall (x:R), (eq (Rabs (Ropp x)) (Rabs x))). +Admitted. + +(Why type) Definition farray: Set ->Set. +Admitted. + +(Why logic) Definition access : forall (A1:Set), (array A1) -> Z -> A1. +Admitted. +Implicit Arguments access. + +(Why logic) Definition update : + forall (A1:Set), (array A1) -> Z -> A1 -> (array A1). +Admitted. +Implicit Arguments update. + +(Why axiom) Lemma access_update : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), (forall (v:A1), (access (update a i v) i) = v))). +Admitted. + +(Why axiom) Lemma access_update_neq : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (j:Z), + (forall (v:A1), (i <> j -> (access (update a i v) j) = (access a j)))))). +Admitted. + +(Why logic) Definition array_length : forall (A1:Set), (array A1) -> Z. +Admitted. +Implicit Arguments array_length. + +(Why predicate) Definition sorted_array (t:(array Z)) (i:Z) (j:Z) + := (forall (k1:Z), + (forall (k2:Z), + ((i <= k1 /\ k1 <= k2) /\ k2 <= j -> (access t k1) <= (access t k2)))). + +(Why predicate) Definition exchange (A226:Set) (a1:(array A226)) (a2:(array A226)) (i:Z) (j:Z) + := (array_length a1) = (array_length a2) /\ + (access a1 i) = (access a2 j) /\ (access a2 i) = (access a1 j) /\ + (forall (k:Z), (k <> i /\ k <> j -> (access a1 k) = (access a2 k))). +Implicit Arguments exchange. + +(Why logic) Definition permut : + forall (A1:Set), (array A1) -> (array A1) -> Z -> Z -> Prop. +Admitted. +Implicit Arguments permut. + +(Why axiom) Lemma permut_refl : + forall (A1:Set), + (forall (t:(array A1)), (forall (l:Z), (forall (u:Z), (permut t t l u)))). +Admitted. + +(Why axiom) Lemma permut_sym : + forall (A1:Set), + (forall (t1:(array A1)), + (forall (t2:(array A1)), + (forall (l:Z), (forall (u:Z), ((permut t1 t2 l u) -> (permut t2 t1 l u)))))). +Admitted. + +(Why axiom) Lemma permut_trans : + forall (A1:Set), + (forall (t1:(array A1)), + (forall (t2:(array A1)), + (forall (t3:(array A1)), + (forall (l:Z), + (forall (u:Z), + ((permut t1 t2 l u) -> ((permut t2 t3 l u) -> (permut t1 t3 l u)))))))). +Admitted. + +(Why axiom) Lemma permut_exchange : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + (forall (i:Z), + (forall (j:Z), + (l <= i /\ i <= u -> + (l <= j /\ j <= u -> ((exchange a1 a2 i j) -> (permut a1 a2 l u)))))))))). +Admitted. + +(Why axiom) Lemma exchange_upd : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (j:Z), + (exchange a (update (update a i (access a j)) j (access a i)) i j)))). +Admitted. + +(Why axiom) Lemma permut_weakening : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l1:Z), + (forall (r1:Z), + (forall (l2:Z), + (forall (r2:Z), + ((l1 <= l2 /\ l2 <= r2) /\ r2 <= r1 -> + ((permut a1 a2 l2 r2) -> (permut a1 a2 l1 r1))))))))). +Admitted. + +(Why axiom) Lemma permut_eq : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + (l <= u -> + ((permut a1 a2 l u) -> + (forall (i:Z), (i < l \/ u (access a2 i) = (access a1 i))))))))). +Admitted. + +(Why predicate) Definition permutation (A235:Set) (a1:(array A235)) (a2:(array A235)) + := (permut a1 a2 0 ((array_length a1) - 1)). +Implicit Arguments permutation. + +(Why axiom) Lemma array_length_update : + forall (A1:Set), + (forall (a:(array A1)), + (forall (i:Z), + (forall (v:A1), (array_length (update a i v)) = (array_length a)))). +Admitted. + +(Why axiom) Lemma permut_array_length : + forall (A1:Set), + (forall (a1:(array A1)), + (forall (a2:(array A1)), + (forall (l:Z), + (forall (u:Z), + ((permut a1 a2 l u) -> (array_length a1) = (array_length a2)))))). +Admitted. + +(Why logic) Definition computer_div : Z -> Z -> Z. +Admitted. + +(Why logic) Definition computer_mod : Z -> Z -> Z. +Admitted. + +(Why logic) Definition math_div : Z -> Z -> Z. +Admitted. + +(Why logic) Definition math_mod : Z -> Z -> Z. +Admitted. + +(Why axiom) Lemma math_div_mod : + (forall (x:Z), + (forall (y:Z), (y <> 0 -> x = (y (math_div x y) + (math_mod x y))))). +Admitted. + +(Why axiom) Lemma math_mod_bound : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> 0 <= (math_mod x y) /\ (math_mod x y) < (abs_int y)))). +Admitted. + +(Why axiom) Lemma computer_div_mod : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> x = (y * (computer_div x y) + (computer_mod x y))))). +Admitted. + +(Why axiom) Lemma computer_div_bound : + (forall (x:Z), + (forall (y:Z), + (x >= 0 /\ y > 0 -> 0 <= (computer_div x y) /\ (computer_div x y) <= x))). +Admitted. + +(Why axiom) Lemma computer_mod_bound : + (forall (x:Z), + (forall (y:Z), (y <> 0 -> (abs_int (computer_mod x y)) < (abs_int y)))). +Admitted. + +(Why axiom) Lemma computer_mod_sign_pos : + (forall (x:Z), + (forall (y:Z), (x >= 0 /\ y <> 0 -> (computer_mod x y) >= 0))). +Admitted. + +(Why axiom) Lemma computer_mod_sign_neg : + (forall (x:Z), + (forall (y:Z), (x <= 0 /\ y <> 0 -> (computer_mod x y) <= 0))). +Admitted. + +(Why axiom) Lemma computer_rounds_toward_zero : + (forall (x:Z), + (forall (y:Z), + (y <> 0 -> (abs_int ((computer_div x y) * y)) <= (abs_int x)))). +Admitted. + +(Why logic) Definition dummy : Z -> Prop. +Admitted. + +(Why logic) Definition assigns : Z -> Prop. +Admitted. + +(Why axiom) Lemma positive_computer_div_div : + (forall (x:Z), + (forall (y:Z), (x > 0 -> (y > 0 -> (computer_div x y) = (math_div x y))))). +Admitted. + +(Why type) Definition set: Set ->Set. +Admitted. + +(Why logic) Definition empty : forall (A1:Set), (set A1). +Admitted. +Set Contextual Implicit. +Implicit Arguments empty. +Unset Contextual Implicit. + +(Why logic) Definition singleton : forall (A1:Set), A1 -> (set A1). +Admitted. +Implicit Arguments singleton. + +(Why logic) Definition range : Z -> Z -> (set Z). +Admitted. + +(Why logic) Definition union : + forall (A1:Set), (set A1) -> (set A1) -> (set A1). +Admitted. +Implicit Arguments union. + +(Why logic) Definition inter : + forall (A1:Set), (set A1) -> (set A1) -> (set A1). +Admitted. +Implicit Arguments inter. + +(Why logic) Definition plus_int : (set Z) -> (set Z) -> (set Z). +Admitted. + +(Why logic) Definition subset : + forall (A1:Set), (set A1) -> (set A1) -> Prop. +Admitted. +Implicit Arguments subset. + +(Why logic) Definition range_inf : Z -> (set Z). +Admitted. + +(Why logic) Definition range_sup : Z -> (set Z). +Admitted. + +(Why logic) Definition integers_set : (set Z). +Admitted. + +(Why logic) Definition equiv : + forall (A1:Set), (set A1) -> (set A1) -> Prop. +Admitted. +Implicit Arguments equiv. + +(Why logic) Definition member : forall (A1:Set), A1 -> (set A1) -> Prop. +Admitted. +Implicit Arguments member. + +(Why axiom) Lemma singleton_def : + forall (A1:Set), (forall (x:A1), (member x (singleton x))). +Admitted. + +(Why axiom) Lemma singleton_eq : + forall (A1:Set), + (forall (x:A1), (forall (y:A1), ((member x (singleton y)) <-> x = y))). +Admitted. + +(Why axiom) Lemma union_member : + forall (A1:Set), + (forall (x:A1), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((member x (union s1 s2)) <-> (member x s1) \/ (member x s2))))). +Admitted. + +(Why axiom) Lemma union_of_empty : + forall (A1:Set), (forall (x:(set A1)), (union x (@empty A1)) = x). +Admitted. + +(Why axiom) Lemma inter_of_empty : + forall (A1:Set), (forall (x:(set A1)), (inter x (@empty A1)) = (@empty A1)). +Admitted. + +(Why axiom) Lemma union_comm : + forall (A1:Set), + (forall (x:(set A1)), (forall (y:(set A1)), (union x y) = (union y x))). +Admitted. + +(Why axiom) Lemma inter_comm : + forall (A1:Set), + (forall (x:(set A1)), (forall (y:(set A1)), (inter x y) = (inter y x))). +Admitted. + +(Why axiom) Lemma inter_member : + forall (A1:Set), + (forall (x:A1), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((member x (inter s1 s2)) <-> (member x s1) /\ (member x s2))))). +Admitted. + +(Why axiom) Lemma plus_int_member_1 : + (forall (sa:(set Z)), + (forall (sb:(set Z)), + (forall (a:Z), + (forall (b:Z), + ((member a sa) -> ((member b sb) -> (member (a + b) (plus_int sa sb)))))))). +Admitted. + +(Why axiom) Lemma plus_int_member_2 : + (forall (sa:(set Z)), + (forall (sb:(set Z)), + (forall (c:Z), + ((member c (plus_int sa sb)) -> + (exists a:Z, + (exists b:Z, (member a sa) /\ (member b sb) /\ c = (a + b))))))). +Admitted. + +(Why axiom) Lemma subset_empty : + forall (A1:Set), (forall (sa:(set A1)), (subset (@empty A1) sa)). +Admitted. + +(Why axiom) Lemma subset_sym : + forall (A1:Set), (forall (sa:(set A1)), (subset sa sa)). +Admitted. + +(Why axiom) Lemma subset_trans : + forall (A1:Set), + (forall (sa:(set A1)), + (forall (sb:(set A1)), + (forall (sc:(set A1)), + ((subset sa sb) -> ((subset sb sc) -> (subset sa sc)))))). +Admitted. + +(Why axiom) Lemma subset_def : + forall (A1:Set), + (forall (sa:(set A1)), + (forall (sb:(set A1)), + ((forall (a:A1), ((member a sa) -> (member a sb))) <-> (subset sa sb)))). +Admitted. + +(Why axiom) Lemma range_def : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), (i <= k /\ k <= j <-> (member k (range i j)))))). +Admitted. + +(Why axiom) Lemma range_def1 : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), (i <= k /\ k <= j -> (member k (range i j)))))). +Admitted. + +(Why axiom) Lemma range_def2 : + (forall (i:Z), + (forall (j:Z), + (forall (k:Z), ((member k (range i j)) -> i <= k /\ k <= j)))). +Admitted. + +(Why axiom) Lemma range_inf_def : + (forall (i:Z), (forall (k:Z), (i <= k <-> (member k (range_inf i))))). +Admitted. + +(Why axiom) Lemma range_sup_def : + (forall (j:Z), (forall (k:Z), (k <= j <-> (member k (range_sup j))))). +Admitted. + +(Why axiom) Lemma integers_set_def : + (forall (k:Z), (k >= 0 <-> (member k integers_set))). +Admitted. + +(Why axiom) Lemma equiv_def : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + ((forall (a:A1), ((member a s1) -> (member a s2))) /\ + (forall (b:A1), ((member b s2) -> (member b s1))) <-> (equiv s1 s2)))). +Admitted. + +(Why axiom) Lemma equiv_refl : + forall (A1:Set), (forall (s:(set A1)), (equiv s s)). +Admitted. + +(Why axiom) Lemma equiv_sym : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), ((equiv s1 s2) -> (equiv s2 s1)))). +Admitted. + +(Why axiom) Lemma equiv_trans : + forall (A1:Set), + (forall (s1:(set A1)), + (forall (s2:(set A1)), + (forall (s3:(set A1)), + ((equiv s1 s2) -> ((equiv s2 s3) -> (equiv s1 s3)))))). +Admitted. + +(Why logic) Definition as_uint8 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint8 (x:Z) := 0 <= x /\ x < 256. + +(Why axiom) Lemma as_uint8_def : (forall (x:Z), (is_uint8 (as_uint8 x))). +Admitted. + +(Why axiom) Lemma as_uint8_involve : + (forall (x:Z), (as_uint8 (as_uint8 x)) = (as_uint8 x)). +Admitted. + +(Why axiom) Lemma is_as_uint8 : + (forall (x:Z), ((is_uint8 x) -> (as_uint8 x) = x)). +Admitted. + +(Why logic) Definition as_sint8 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint8 (x:Z) := (-128) <= x /\ x < 128. + +(Why axiom) Lemma as_sint8_def : (forall (x:Z), (is_sint8 (as_sint8 x))). +Admitted. + +(Why axiom) Lemma as_sint8_involve : + (forall (x:Z), (as_sint8 (as_sint8 x)) = (as_sint8 x)). +Admitted. + +(Why axiom) Lemma is_as_sint8 : + (forall (x:Z), ((is_sint8 x) -> (as_sint8 x) = x)). +Admitted. + +(Why logic) Definition as_uint16 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint16 (x:Z) := 0 <= x /\ x < 65536. + +(Why axiom) Lemma as_uint16_def : + (forall (x:Z), (is_uint16 (as_uint16 x))). +Admitted. + +(Why axiom) Lemma as_uint16_involve : + (forall (x:Z), (as_uint16 (as_uint16 x)) = (as_uint16 x)). +Admitted. + +(Why axiom) Lemma is_as_uint16 : + (forall (x:Z), ((is_uint16 x) -> (as_uint16 x) = x)). +Admitted. + +(Why logic) Definition as_sint16 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint16 (x:Z) := (-32768) <= x /\ x < 32768. + +(Why axiom) Lemma as_sint16_def : + (forall (x:Z), (is_sint16 (as_sint16 x))). +Admitted. + +(Why axiom) Lemma as_sint16_involve : + (forall (x:Z), (as_sint16 (as_sint16 x)) = (as_sint16 x)). +Admitted. + +(Why axiom) Lemma is_as_sint16 : + (forall (x:Z), ((is_sint16 x) -> (as_sint16 x) = x)). +Admitted. + +(Why logic) Definition as_uint32 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint32 (x:Z) := 0 <= x /\ x < 4294967296. + +(Why axiom) Lemma as_uint32_def : + (forall (x:Z), (is_uint32 (as_uint32 x))). +Admitted. + +(Why axiom) Lemma as_uint32_involve : + (forall (x:Z), (as_uint32 (as_uint32 x)) = (as_uint32 x)). +Admitted. + +(Why axiom) Lemma is_as_uint32 : + (forall (x:Z), ((is_uint32 x) -> (as_uint32 x) = x)). +Admitted. + +(Why logic) Definition as_sint32 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint32 (x:Z) + := (-2147483648) <= x /\ x < 2147483648. + +(Why axiom) Lemma as_sint32_def : + (forall (x:Z), (is_sint32 (as_sint32 x))). +Admitted. + +(Why axiom) Lemma as_sint32_involve : + (forall (x:Z), (as_sint32 (as_sint32 x)) = (as_sint32 x)). +Admitted. + +(Why axiom) Lemma is_as_sint32 : + (forall (x:Z), ((is_sint32 x) -> (as_sint32 x) = x)). +Admitted. + +(Why logic) Definition as_uint64 : Z -> Z. +Admitted. + +(Why predicate) Definition is_uint64 (x:Z) + := 0 <= x /\ x < 18446744073709551616. + +(Why axiom) Lemma as_uint64_def : + (forall (x:Z), (is_uint64 (as_uint64 x))). +Admitted. + +(Why axiom) Lemma as_uint64_involve : + (forall (x:Z), (as_uint64 (as_uint64 x)) = (as_uint64 x)). +Admitted. + +(Why axiom) Lemma is_as_uint64 : + (forall (x:Z), ((is_uint64 x) -> (as_uint64 x) = x)). +Admitted. + +(Why logic) Definition as_sint64 : Z -> Z. +Admitted. + +(Why predicate) Definition is_sint64 (x:Z) + := (-9223372036854775808) <= x /\ x < 9223372036854775808. + +(Why axiom) Lemma as_sint64_def : + (forall (x:Z), (is_sint64 (as_sint64 x))). +Admitted. + +(Why axiom) Lemma as_sint64_involve : + (forall (x:Z), (as_sint64 (as_sint64 x)) = (as_sint64 x)). +Admitted. + +(Why axiom) Lemma is_as_sint64 : + (forall (x:Z), ((is_sint64 x) -> (as_sint64 x) = x)). +Admitted. + +(Why logic) Definition as_float16 : R -> R. +Admitted. + +(Why logic) Definition is_float16 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float16_def : + (forall (x:R), (is_float16 (as_float16 x))). +Admitted. + +(Why axiom) Lemma as_float16_involve : + (forall (x:R), (eq (as_float16 (as_float16 x)) (as_float16 x))). +Admitted. + +(Why axiom) Lemma is_as_float16 : + (forall (x:R), ((is_float16 x) -> (eq (as_float16 x) x))). +Admitted. + +(Why logic) Definition as_float32 : R -> R. +Admitted. + +(Why logic) Definition is_float32 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float32_def : + (forall (x:R), (is_float32 (as_float32 x))). +Admitted. + +(Why axiom) Lemma as_float32_involve : + (forall (x:R), (eq (as_float32 (as_float32 x)) (as_float32 x))). +Admitted. + +(Why axiom) Lemma is_as_float32 : + (forall (x:R), ((is_float32 x) -> (eq (as_float32 x) x))). +Admitted. + +(Why logic) Definition as_float64 : R -> R. +Admitted. + +(Why logic) Definition is_float64 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float64_def : + (forall (x:R), (is_float64 (as_float64 x))). +Admitted. + +(Why axiom) Lemma as_float64_involve : + (forall (x:R), (eq (as_float64 (as_float64 x)) (as_float64 x))). +Admitted. + +(Why axiom) Lemma is_as_float64 : + (forall (x:R), ((is_float64 x) -> (eq (as_float64 x) x))). +Admitted. + +(Why logic) Definition as_float128 : R -> R. +Admitted. + +(Why logic) Definition is_float128 : R -> Prop. +Admitted. + +(Why axiom) Lemma as_float128_def : + (forall (x:R), (is_float128 (as_float128 x))). +Admitted. + +(Why axiom) Lemma as_float128_involve : + (forall (x:R), (eq (as_float128 (as_float128 x)) (as_float128 x))). +Admitted. + +(Why axiom) Lemma is_as_float128 : + (forall (x:R), ((is_float128 x) -> (eq (as_float128 x) x))). +Admitted. + +(Why type) Definition data: Set. +Admitted. + +(Why logic) Definition data_of_uint8 : Z -> data. +Admitted. + +(Why logic) Definition uint8_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint8_of_data : + (forall (d:data), (is_uint8 (uint8_of_data d))). +Admitted. + +(Why axiom) Lemma uint8ofdata_dataofuint8 : + (forall (x:Z), ((is_uint8 x) -> (uint8_of_data (data_of_uint8 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint8 : Z -> data. +Admitted. + +(Why logic) Definition sint8_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint8_of_data : + (forall (d:data), (is_sint8 (sint8_of_data d))). +Admitted. + +(Why axiom) Lemma sint8ofdata_dataofsint8 : + (forall (x:Z), ((is_sint8 x) -> (sint8_of_data (data_of_sint8 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint16 : Z -> data. +Admitted. + +(Why logic) Definition uint16_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint16_of_data : + (forall (d:data), (is_uint16 (uint16_of_data d))). +Admitted. + +(Why axiom) Lemma uint16ofdata_dataofuint16 : + (forall (x:Z), ((is_uint16 x) -> (uint16_of_data (data_of_uint16 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint16 : Z -> data. +Admitted. + +(Why logic) Definition sint16_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint16_of_data : + (forall (d:data), (is_sint16 (sint16_of_data d))). +Admitted. + +(Why axiom) Lemma sint16ofdata_dataofsint16 : + (forall (x:Z), ((is_sint16 x) -> (sint16_of_data (data_of_sint16 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint32 : Z -> data. +Admitted. + +(Why logic) Definition uint32_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint32_of_data : + (forall (d:data), (is_uint32 (uint32_of_data d))). +Admitted. + +(Why axiom) Lemma uint32ofdata_dataofuint32 : + (forall (x:Z), ((is_uint32 x) -> (uint32_of_data (data_of_uint32 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint32 : Z -> data. +Admitted. + +(Why logic) Definition sint32_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint32_of_data : + (forall (d:data), (is_sint32 (sint32_of_data d))). +Admitted. + +(Why axiom) Lemma sint32ofdata_dataofsint32 : + (forall (x:Z), ((is_sint32 x) -> (sint32_of_data (data_of_sint32 x)) = x)). +Admitted. + +(Why logic) Definition data_of_uint64 : Z -> data. +Admitted. + +(Why logic) Definition uint64_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_uint64_of_data : + (forall (d:data), (is_uint64 (uint64_of_data d))). +Admitted. + +(Why axiom) Lemma uint64ofdata_dataofuint64 : + (forall (x:Z), ((is_uint64 x) -> (uint64_of_data (data_of_uint64 x)) = x)). +Admitted. + +(Why logic) Definition data_of_sint64 : Z -> data. +Admitted. + +(Why logic) Definition sint64_of_data : data -> Z. +Admitted. + +(Why axiom) Lemma is_sint64_of_data : + (forall (d:data), (is_sint64 (sint64_of_data d))). +Admitted. + +(Why axiom) Lemma sint64ofdata_dataofsint64 : + (forall (x:Z), ((is_sint64 x) -> (sint64_of_data (data_of_sint64 x)) = x)). +Admitted. + +(Why logic) Definition data_of_float16 : R -> data. +Admitted. + +(Why logic) Definition float16_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float16_of_data : + (forall (d:data), (is_float16 (float16_of_data d))). +Admitted. + +(Why axiom) Lemma float16ofdata_dataoffloat16 : + (forall (x:R), + ((is_float16 x) -> (eq (float16_of_data (data_of_float16 x)) x))). +Admitted. + +(Why logic) Definition data_of_float32 : R -> data. +Admitted. + +(Why logic) Definition float32_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float32_of_data : + (forall (d:data), (is_float32 (float32_of_data d))). +Admitted. + +(Why axiom) Lemma float32ofdata_dataoffloat32 : + (forall (x:R), + ((is_float32 x) -> (eq (float32_of_data (data_of_float32 x)) x))). +Admitted. + +(Why logic) Definition data_of_float64 : R -> data. +Admitted. + +(Why logic) Definition float64_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float64_of_data : + (forall (d:data), (is_float64 (float64_of_data d))). +Admitted. + +(Why axiom) Lemma float64ofdata_dataoffloat64 : + (forall (x:R), + ((is_float64 x) -> (eq (float64_of_data (data_of_float64 x)) x))). +Admitted. + +(Why logic) Definition data_of_float128 : R -> data. +Admitted. + +(Why logic) Definition float128_of_data : data -> R. +Admitted. + +(Why axiom) Lemma is_float128_of_data : + (forall (d:data), (is_float128 (float128_of_data d))). +Admitted. + +(Why axiom) Lemma float128ofdata_dataoffloat128 : + (forall (x:R), + ((is_float128 x) -> (eq (float128_of_data (data_of_float128 x)) x))). +Admitted. + +(Why logic) Definition set_range_index : + forall (A1:Set), (array A1) -> (set Z) -> Z -> (array A1). +Admitted. +Implicit Arguments set_range_index. + +(Why axiom) Lemma set_range_def : + forall (A1:Set), + (forall (t:(array A1)), + (forall (rg:(set Z)), + (forall (k:Z), + (forall (i:Z), + (~(member i rg) -> (access (set_range_index t rg k) i) = (access t i)))))). +Admitted. + +(Why logic) Definition bnot : Z -> Z. +Admitted. + +(Why logic) Definition band : Z -> Z -> Z. +Admitted. + +(Why logic) Definition bor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition bxor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition lshift : Z -> Z -> Z. +Admitted. + +(Why logic) Definition rshift : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_not : Z -> Z. +Admitted. + +(Why logic) Definition int_and : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_or : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_xor : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_lsh : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_rshs : Z -> Z -> Z. +Admitted. + +(Why logic) Definition int_rshu : Z -> Z -> Z. +Admitted. + +(Why logic) Definition addr : Z -> Z -> Z. +Admitted. + +(Why logic) Definition offset : Z -> Z. +Admitted. + +(Why logic) Definition base : Z -> Z. +Admitted. + +(Why axiom) Lemma addr_def : + (forall (a:Z), + (forall (b:Z), + (forall (d:Z), ((addr b d) = a -> (base a) = b /\ (offset a) = d)))). +Admitted. + +(Why axiom) Lemma addr_id : (forall (p:Z), (addr (base p) (offset p)) = p). +Admitted. + +(Why logic) Definition minus_addr : Z -> Z -> Z. +Admitted. + +(Why axiom) Lemma minus_addr_def : + (forall (a:Z), + (forall (b:Z), + ((base a) = (base b) -> (minus_addr a b) = ((offset a) - (offset b))))). +Admitted. + +(Why predicate) Definition addr_lt (a:Z) (b:Z) + := (base a) = (base b) /\ (offset a) < (offset b). + +(Why function) Definition addr_lt_bool (a:Z) (b:Z) + := (bool_and + (eq_int_bool (base a) (base b)) (lt_int_bool (offset a) (offset b))). + +(Why predicate) Definition addr_le (a:Z) (b:Z) + := (base a) = (base b) /\ (offset a) <= (offset b). + +(Why function) Definition addr_le_bool (a:Z) (b:Z) + := (bool_and + (eq_int_bool (base a) (base b)) (le_int_bool (offset a) (offset b))). + +(Why predicate) Definition addr_eq (a:Z) (b:Z) + := (base a) = (base b) /\ (offset a) = (offset b). + +(Why function) Definition addr_eq_bool (a:Z) (b:Z) + := (bool_and + (eq_int_bool (base a) (base b)) (eq_int_bool (offset a) (offset b))). + +(Why axiom) Lemma cmp_null : (forall (p:Z), (p = 0 <-> (addr_eq p 0))). +Admitted. + +(Why axiom) Lemma cmp_null_bool : + (forall (p:Z), (p = 0 <-> (addr_eq_bool p 0) = true)). +Admitted. + +(Why axiom) Lemma cmp_null_not : + (forall (p:Z), (p <> 0 <-> ~(addr_eq p 0))). +Admitted. + +(Why axiom) Lemma cmp_null_bool_not : + (forall (p:Z), (p <> 0 <-> (addr_eq_bool p 0) = false)). +Admitted. + +(Why logic) Definition addr_of_data : data -> Z. +Admitted. + +(Why logic) Definition data_of_addr : Z -> data. +Admitted. + +(Why axiom) Lemma addrofdata_dataofaddr : + (forall (p:Z), (addr_of_data (data_of_addr p)) = p). +Admitted. + +(Why predicate) Definition valid (ta:(array Z)) (p:Z) (n:Z) + := (n > 0 -> 0 <= (offset p) /\ ((offset p) + n) <= (access ta (base p))). + +(Why logic) Definition global : (array Z) -> Prop. +Admitted. + +(Why logic) Definition is_fresh : (array data) -> (array Z) -> Z -> Prop. +Admitted. + +(Why axiom) Lemma fresh : + (forall (mem:(array data)), + (forall (ta:(array Z)), + (forall (ta':(array Z)), + (forall (x:Z), + (forall (p:Z), + (forall (n:Z), + ((is_fresh mem ta x) -> + ((access ta x) = 0 -> + ((access ta (base p)) = (access ta' (base p)) -> + ((valid ta' p n) -> + (forall (d:Z), (forall (sz:Z), (addr x d) <> p)))))))))))). +Admitted. + +(Why axiom) Lemma fresh_access : + (forall (mem:(array data)), + (forall (mem':(array data)), + (forall (ta:(array Z)), + (forall (ta':(array Z)), + (forall (b:Z), + (forall (p:Z), + (forall (n:Z), + ((is_fresh mem ta b) -> + ((access ta b) = 0 -> + ((valid ta' p n) -> + ((access ta (base p)) = (access ta' (base p)) -> + ((access mem p) = (access mem' p) -> + (forall (d:Z), (addr b d) <> (addr_of_data (access mem' p))))))))))))))). +Admitted. + +(Why function) Definition addr_shift (p:Z) (dofs:Z) + := (addr (base p) ((offset p) + dofs)). + +(Why predicate) Definition separated_on_addr (p:Z) (p':Z) (n1:Z) (n2:Z) + := ((base p) = (base p') -> ((offset p) + n1) <= (offset p') \/ + (offset p) >= ((offset p') + n2)). + +(Why type) Definition zone: Set. +Admitted. + +(Why logic) Definition zrange : Z -> Z -> Z -> zone. +Admitted. + +(Why logic) Definition zempty : zone. +Admitted. + +(Why logic) Definition zunion : zone -> zone -> zone. +Admitted. + +(Why logic) Definition included : zone -> zone -> Prop. +Admitted. + +(Why logic) Definition is_havoc : + (array Z) -> (array data) -> zone -> (array data) -> Prop. +Admitted. + +(Why logic) Definition is_block : zone -> Prop. +Admitted. + +(Why axiom) Lemma is_block_zrange : + (forall (x:Z), + (forall (ofs:Z), + (forall (len:Z), (len > 0 -> (is_block (zrange x ofs len)))))). +Admitted. + +(Why axiom) Lemma is_not_block_zempty : ~(is_block zempty). +Admitted. + +(Why function) Definition zrange_of_addr (p:Z) + := (zrange (base p) (offset p) 1). + +(Why function) Definition zrange_of_addr_range (p:Z) (dofs:Z) (n:Z) + := (zrange (base p) ((offset p) + dofs) n). + +(Why logic) Definition separated : zone -> zone -> Prop. +Admitted. + +(Why axiom) Lemma sep_zrange : + (forall (b:Z), + (forall (b':Z), + (forall (d:Z), + (forall (d':Z), + (forall (sz:Z), + (forall (sz':Z), + ((separated (zrange b d sz) (zrange b' d' sz')) <-> + (separated_on_addr (addr b d) (addr b' d') sz sz')))))))). +Admitted. + +(Why axiom) Lemma separated_sym : + (forall (z:zone), + (forall (z':zone), ((separated z z') -> (separated z' z)))). +Admitted. + +(Why axiom) Lemma sep_empty : (forall (z:zone), (separated zempty z)). +Admitted. + +(Why axiom) Lemma sep_union : + (forall (z:zone), + (forall (z':zone), + (forall (r:zone), + ((separated z (zunion z' r)) <-> (separated z z') /\ (separated z r))))). +Admitted. + +(Why axiom) Lemma left_empty : (forall (z:zone), (zunion z zempty) = z). +Admitted. + +(Why axiom) Lemma right_empty : (forall (z:zone), (zunion zempty z) = z). +Admitted. + +(Why axiom) Lemma union_same : (forall (z:zone), (zunion z z) = z). +Admitted. + +(Why axiom) Lemma union_sym : + (forall (z:zone), (forall (z':zone), (zunion z z') = (zunion z' z))). +Admitted. + +(Why axiom) Lemma union_assoc : + (forall (z:zone), + (forall (r:zone), + (forall (s:zone), (zunion (zunion z r) s) = (zunion z (zunion r s))))). +Admitted. + +(Why axiom) Lemma inc_range_range : + (forall (b:Z), + (forall (d:Z), + (forall (sz:Z), + (forall (b':Z), + (forall (d':Z), + (forall (sz':Z), + ((included (zrange b d sz) (zrange b' d' sz')) <-> + (d <= (d + sz) -> b = b' /\ d' <= d /\ (d + sz) <= (d' + sz'))))))))). +Admitted. + +(Why axiom) Lemma inc_empty : (forall (z:zone), (included zempty z)). +Admitted. + +(Why axiom) Lemma inc_same : (forall (z:zone), (included z z)). +Admitted. + +(Why axiom) Lemma inc_range_empty : + (forall (b:Z), + (forall (d:Z), + (forall (sz:Z), ((included (zrange b d sz) zempty) <-> b > (b + sz))))). +Admitted. + +(Why axiom) Lemma inc_union_right : + (forall (z:zone), + (forall (r:zone), + (forall (s:zone), + ((included z r) \/ (included z s) -> (included z (zunion r s)))))). +Admitted. + +(Why axiom) Lemma inc_union_left : + (forall (s:zone), + (forall (z:zone), + (forall (z':zone), + ((included s z) -> ((included z' z) -> (included (zunion s z') z)))))). +Admitted. + +(Why logic) Definition access_range : (array data) -> zone -> data. +Admitted. + +(Why logic) Definition update_range : + (array data) -> zone -> data -> (array data). +Admitted. + +(Why axiom) Lemma access_update_range_same : + (forall (m:(array data)), + (forall (z:zone), + (forall (d:data), + ((is_block z) -> (access_range (update_range m z d) z) = d)))). +Admitted. + +(Why axiom) Lemma access_update_range_sep : + (forall (m:(array data)), + (forall (v:data), + (forall (z:zone), + (forall (z':zone), + ((is_block z) -> + ((is_block z') -> + ((separated z z') -> + (access_range (update_range m z v) z') = (access_range m z')))))))). +Admitted. + +(Why axiom) Lemma access_range_update_addr_sep : + (forall (m:(array data)), + (forall (v:data), + (forall (z:zone), + (forall (p:Z), + ((is_block z) -> + ((separated z (zrange_of_addr p)) -> + (access_range (update m p v) z) = (access_range m z))))))). +Admitted. + +(Why axiom) Lemma access_update_range_addr_sep : + (forall (m:(array data)), + (forall (v:data), + (forall (z:zone), + (forall (p:Z), + ((is_block z) -> + ((separated z (zrange_of_addr p)) -> + (access (update_range m z v) p) = (access m p))))))). +Admitted. + +(Why axiom) Lemma access_update_sep : + (forall (m:(array data)), + (forall (v:data), + (forall (p:Z), + (forall (q:Z), + ((separated (zrange_of_addr p) (zrange_of_addr q)) -> + (access (update m p v) q) = (access m q)))))). +Admitted. + +(Why logic) Definition update_havoc : + (array data) -> zone -> data -> (array data). +Admitted. + +(Why axiom) Lemma load_havoc : + (forall (m:(array data)), + (forall (v:data), + (forall (z:zone), + (forall (p:Z), + ((separated z (zrange_of_addr p)) -> + (access (update_havoc m z v) p) = (access m p)))))). +Admitted. + +(Why axiom) Lemma load_is_havoc : + (forall (alloc:(array Z)), + (forall (mem:(array data)), + (forall (mem':(array data)), + (forall (p:Z), + (forall (z:zone), + ((included (zrange_of_addr p) z) -> + ((is_havoc alloc mem z mem') -> (access mem' p) = (access mem p)))))))). +Admitted. + +(Why logic) Definition is_assignable : (array Z) -> zone -> zone -> Prop. +Admitted. + +(Why axiom) Lemma is_assignable_range_free : + (forall (alloc:(array Z)), + (forall (p:Z), + (forall (z:zone), + ((access alloc (base p)) = 0 -> + (is_assignable alloc (zrange_of_addr p) z))))). +Admitted. + +(Why axiom) Lemma is_assignable_included : + (forall (alloc:(array Z)), + (forall (z:zone), + (forall (z':zone), ((included z z') -> (is_assignable alloc z z'))))). +Admitted. + +(Why axiom) Lemma same_havoc : + (forall (alloc:(array Z)), + (forall (mem:(array data)), (forall (z:zone), (is_havoc alloc mem z mem)))). +Admitted. + +(Why axiom) Lemma havoc_sym : + (forall (alloc:(array Z)), + (forall (m1:(array data)), + (forall (m2:(array data)), + (forall (z:zone), ((is_havoc alloc m2 z m1) -> (is_havoc alloc m1 z m2)))))). +Admitted. + +(Why axiom) Lemma store_havoc : + (forall (alloc:(array Z)), + (forall (mem:(array data)), + (forall (mem':(array data)), + (forall (p:Z), + (forall (v:data), + (forall (z:zone), + ((is_assignable alloc (zrange_of_addr p) z) -> + ((is_havoc alloc mem z mem') -> + (is_havoc alloc mem z (update mem' p v)))))))))). +Admitted. + +(Why axiom) Lemma store_havoc_havoc : + (forall (alloc:(array Z)), + (forall (mem:(array data)), + (forall (mem':(array data)), + (forall (v:data), + (forall (z':zone), + (forall (z:zone), + ((is_assignable alloc z' z) -> + ((is_havoc alloc mem z mem') -> + (is_havoc alloc mem z (update_havoc mem' z' v)))))))))). +Admitted. + +(Why axiom) Lemma store_range_havoc : + (forall (alloc:(array Z)), + (forall (mem:(array data)), + (forall (mem':(array data)), + (forall (v:data), + (forall (z':zone), + (forall (z:zone), + ((is_block z') -> + ((is_assignable alloc z' z) -> + ((is_havoc alloc mem z mem') -> + (is_havoc alloc mem z (update_range mem' z' v))))))))))). +Admitted. + +(Why axiom) Lemma addr_base : + (forall (b:Z), (forall (d:Z), (base (addr b d)) = b)). +Admitted. + +(Why axiom) Lemma addr_offset : + (forall (b:Z), (forall (d:Z), (offset (addr b d)) = d)). +Admitted. + +(Why axiom) Lemma base_sep : + (forall (b:Z), + (forall (b':Z), + (forall (d:Z), (forall (d':Z), (b <> b' -> (addr b d) <> (addr b' d')))))). +Admitted. + +(Why axiom) Lemma addr_inj1 : + (forall (b:Z), + (forall (b':Z), (forall (d:Z), (b = b' <-> (addr b d) = (addr b' d))))). +Admitted. + +(Why axiom) Lemma addr_inj2 : + (forall (b:Z), + (forall (d:Z), (forall (d':Z), (d = d' <-> (addr b d) = (addr b d'))))). +Admitted. + +(Why axiom) Lemma addr_lt_eq : (forall (a:Z), ~(addr_lt a a)). +Admitted. + +(Why axiom) Lemma addr_le_eq : (forall (a:Z), (addr_le a a)). +Admitted. + +(Why axiom) Lemma minus_pos_lt : + (forall (a:Z), + (forall (b:Z), + ((base a) = (base b) -> (((offset b) - (offset a)) > 0 -> (addr_lt a b))))). +Admitted. + +(Why axiom) Lemma minus_pos_le : + (forall (a:Z), + (forall (b:Z), + ((base a) = (base b) -> (((offset b) - (offset a)) >= 0 -> (addr_le a b))))). +Admitted. + +(Why axiom) Lemma addr_lt_le : + (forall (a:Z), (forall (b:Z), ((addr_lt a b) -> (addr_le a b)))). +Admitted. + +(Why axiom) Lemma havoc_union_update_left : + (forall (alloc:(array Z)), + (forall (m:(array data)), + (forall (m':(array data)), + (forall (p:Z), + (forall (v:data), + (forall (asgns:zone), + ((is_havoc alloc m (zunion (zrange_of_addr p) asgns) m') -> + (is_havoc alloc m (zunion (zrange_of_addr p) asgns) (update m' p v))))))))). +Admitted. + +(Why axiom) Lemma havoc_union_update_right : + (forall (alloc:(array Z)), + (forall (m:(array data)), + (forall (m':(array data)), + (forall (p:Z), + (forall (v:data), + (forall (z:zone), + (forall (asgns:zone), + ((included (zrange_of_addr p) asgns) -> + ((is_havoc alloc m (zunion z asgns) m') -> + (is_havoc alloc m (zunion z asgns) (update m' p v))))))))))). +Admitted. + +(Why axiom) Lemma havoc_union_update_range_left : + (forall (alloc:(array Z)), + (forall (m:(array data)), + (forall (m':(array data)), + (forall (v:data), + (forall (p:Z), + (forall (asgns:zone), + ((is_havoc alloc m (zunion (zrange_of_addr p) asgns) m') -> + (is_havoc + alloc m (zunion (zrange_of_addr p) asgns) (update_range + m' (zrange_of_addr p) v))))))))). +Admitted. + +(Why axiom) Lemma havoc_union_update_range_right : + (forall (alloc:(array Z)), + (forall (m:(array data)), + (forall (m':(array data)), + (forall (v:data), + (forall (p:Z), + (forall (z:zone), + (forall (asgns:zone), + ((included (zrange_of_addr p) asgns) -> + ((is_havoc alloc m (zunion z asgns) m') -> + (is_havoc + alloc m (zunion z asgns) (update_range m' (zrange_of_addr p) v))))))))))). +Admitted. + +(Why axiom) Lemma inc_union_union : + (forall (z0:zone), + (forall (z1:zone), + (forall (z2:zone), + (forall (z3:zone), + ((included z0 z2) -> + ((included z1 z3) -> (included (zunion z0 z1) (zunion z2 z3)))))))). +Admitted. + +(Why axiom) Lemma inc_sub_zone : + (forall (z:zone), + (forall (z':zone), + (included (zunion (zunion z z') (zunion z' z)) (zunion z' z)))). +Admitted. + +(Why axiom) Lemma inc_permut_union : + (forall (z:zone), + (forall (z':zone), + (forall (r:zone), + (included (zunion (zunion z z') r) (zunion (zunion z r) z'))))). +Admitted. + +(Why axiom) Lemma inc_permut2 : + (forall (z:zone), + (forall (s:zone), + (forall (r:zone), + (included + (zunion (zunion (zunion (zunion z s) r) r) s) (zunion (zunion z r) s))))). +Admitted. + +(Why axiom) Lemma union_assoc2 : + (forall (z:zone), + (forall (z':zone), (zunion z (zunion z z')) = (zunion z z'))). +Admitted. + +(Why axiom) Lemma addr_shift_0 : (forall (p:Z), (addr_shift p 0) = p). +Admitted. + +(Why axiom) Lemma addr_shift_shift : + (forall (p:Z), + (forall (d:Z), + (forall (d':Z), (addr_shift (addr_shift p d) d') = + (addr_shift p (d + d'))))). +Admitted. + +(Why axiom) Lemma valid_elt : + (forall (ta:(array Z)), + (forall (p:Z), + (forall (i:Z), + (forall (n:Z), + (n > 0 -> + ((valid ta p n) -> + (0 <= i -> ((i + 1) <= n -> (valid ta (addr_shift p i) 1))))))))). +Admitted. + +(Why axiom) Lemma separated_on_addr_sym : + (forall (p:Z), + (forall (q:Z), + (forall (n:Z), + (forall (m:Z), + ((separated_on_addr p q n m) -> (separated_on_addr q p m n)))))). +Admitted. + +(Why axiom) Lemma separated_on_addr_inc : + (forall (b:Z), + (forall (d:Z), + (forall (d':Z), + (forall (sz:Z), + (forall (sz':Z), + (forall (b1:Z), + (forall (d1:Z), + (forall (sz1:Z), + ((separated_on_addr (addr b1 d1) (addr b d) sz1 sz) -> + (d <= d' -> + ((d' + sz') <= (d + sz) -> + (separated_on_addr (addr b1 d1) (addr b d') sz1 sz')))))))))))). +Admitted. + +(Why axiom) Lemma separated_inc : + (forall (b:Z), + (forall (d:Z), + (forall (d':Z), + (forall (sz:Z), + (forall (sz':Z), + (forall (b1:Z), + (forall (d1:Z), + (forall (sz1:Z), + ((separated (zrange b1 d1 sz1) (zrange b d sz)) -> + (d <= d' -> + ((d' + sz') <= (d + sz) -> + (separated (zrange b1 d1 sz1) (zrange b d' sz'))))))))))))). +Admitted. + +(Why axiom) Lemma separated_one_elt : + (forall (n:Z), + (forall (m:Z), + (forall (b:Z), + (forall (d:Z), + (forall (sz:Z), + (forall (b':Z), + (forall (d':Z), + (forall (sz':Z), + (0 < n -> + (0 < m -> + ((separated (zrange b d (sz * n)) (zrange b' d' (sz' * m))) -> + (forall (i:Z), + (forall (j:Z), + (0 <= i -> + (0 <= j -> + ((d + i + sz) <= (d + sz * n) -> + ((d' + j + sz') <= (d' + sz' * m) -> + (separated (zrange b (d + i) sz) (zrange b' (d' + j) sz'))))))))))))))))))). +Admitted. + +(Why axiom) Lemma store_pointer : + (forall (x:Z), + (forall (ofs:Z), + (forall (y:Z), + (forall (ofs':Z), (separated_on_addr (addr x ofs) (addr y ofs') 1 1) \/ + (addr x ofs) = (addr y ofs'))))). +Admitted. + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/store_model.why frama-c-20111001+nitrogen+dfsg/src/wp/share/store_model.why --- frama-c-20110201+carbon+dfsg/src/wp/share/store_model.why 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/store_model.why 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,912 @@ +(* --- Headers for WHY --- ) + +include "bool.why" +include "integer.why" +include "real.why" +include "arrays.why" +include "divisions.why" +( -------------------------------------------------------------------------- ) +( --- ACSL Definitions --- ) +( -------------------------------------------------------------------------- ) + +logic dummy : int -> prop +logic assigns : int -> prop + + +( -------------------------------------------------------------------------- ) +( --- Divisions enhanced specification --- ) +( -------------------------------------------------------------------------- *) + +axiom positive_computer_div_div: + forall x,y:int. + x >0 -> y >0 -> computer_div(x,y) = math_div(x,y) + + +(************************************************************************) +(* Specification of Set as First Class Value *) +(************************************************************************) +(* From Figure 2.6 in ACSL:ANSI/ISO C Specification Language ) + +type 'a set + +logic empty : 'a set +logic singleton : 'a -> 'a set +logic range : int,int -> int set +logic union : 'a set , 'a set -> 'a set +logic inter : 'a set , 'a set -> 'a set +logic plus_int : int set, int set -> int set +logic subset : 'a set,'a set -> prop +logic range_inf: int -> int set +logic range_sup:int->int set +logic integers_set : int set +logic equiv : 'a set ,'a set -> prop +logic member : 'a,'a set -> prop + +axiom singleton_def : + forall x:'a. member (x, singleton(x)) + +axiom singleton_eq: + forall x,y:'a. member(x,singleton(y)) <-> x=y + +axiom union_member : + forall x:'a. forall s1,s2:'a set [member(x, union(s1,s2))]. + member(x, union(s1,s2)) <-> member(x,s1) or member(x,s2) + +axiom union_of_empty : + forall x:'a set [union(x,empty)]. union(x,empty) = x + +axiom inter_of_empty : + forall x:'a set [inter(x,empty)]. inter(x,empty) = empty + +axiom union_comm : + forall x,y:'a set. union(x,y) = union(y,x) + +axiom inter_comm : + forall x,y:'a set. inter(x,y) = inter(y,x) + +axiom inter_member : + forall x:'a. forall s1,s2:'a set [member(x,inter(s1,s2))]. + member(x,inter(s1,s2)) <-> member(x,s1) and member(x,s2) + +axiom plus_int_member_1: + forall sa,sb:int set. + forall a,b:int [member((a+b), plus_int(sa,sb))]. + member(a,sa) -> member(b,sb) -> + member((a+b), plus_int(sa,sb)) + +axiom plus_int_member_2: + forall sa,sb:int set. + forall c:int. + member(c,plus_int(sa,sb)) -> + exists a:int. exists b:int. + member(a,sa) and member(b,sb) and c=a+b + +axiom subset_empty : + forall sa:'a set. subset(empty,sa) + +axiom subset_sym: + forall sa:'a set. subset(sa,sa) + +axiom subset_trans : + forall sa,sb,sc: 'a set. + subset(sa,sb) -> + subset(sb,sc) -> + subset(sa,sc) + +axiom subset_def: + forall sa,sb:'a set [subset(sa,sb)]. + (forall a:'a. member(a,sa) -> member(a,sb)) <-> subset(sa,sb) + + +axiom range_def: + forall i,j,k:int. i <= k<= j <-> member (k,range(i,j)) + +axiom range_def1: + forall i,j,k:int. i <= k<= j -> member (k,range(i,j)) + +axiom range_def2: + forall i,j,k:int.member (k,range(i,j)) -> i <= k<= j + +axiom range_inf_def: ( range_inf(i) is [ i .. ] ) + forall i,k: int. i <= k <-> member (k,range_inf(i)) + +axiom range_sup_def: ( range_sup(j) is [ .. j ] *) + forall j,k: int. k <= j <-> member (k,range_sup(j)) + +axiom integers_set_def: + forall k:int. k >= 0 <-> member(k,integers_set) + +axiom equiv_def: + forall s1,s2:'a set [equiv(s1,s2)]. ( + (forall a:'a. member(a,s1) -> member(a,s2)) and + (forall b:'a. member(b,s2) -> member(b,s1))) <-> + equiv(s1,s2) + +axiom equiv_refl: + forall s:'a set. equiv(s,s) + +axiom equiv_sym: + forall s1,s2:'a set. equiv(s1,s2) -> equiv(s2,s1) + +axiom equiv_trans: + forall s1,s2,s3:'a set. + equiv(s1,s2) -> equiv(s2,s3) -> equiv(s1,s3) + + + +(************************************************************************) +(* Integers and Reals ) +() + + +logic as_uint8 :int -> int +predicate is_uint8(x:int) = 0 <= x < 256 +axiom as_uint8_def : forall x:int. is_uint8(as_uint8(x)) +axiom as_uint8_involve : + forall x:int [as_uint8(as_uint8(x))]. as_uint8(as_uint8(x)) = as_uint8(x) +axiom is_as_uint8: forall x:int [as_uint8(x)]. is_uint8(x) -> as_uint8(x) = x + +logic as_sint8 :int -> int +predicate is_sint8(x:int) = -128 <= x < 128 +axiom as_sint8_def : forall x:int. is_sint8(as_sint8(x)) +axiom as_sint8_involve : + forall x:int [as_sint8(as_sint8(x))]. as_sint8(as_sint8(x)) = as_sint8(x) +axiom is_as_sint8: forall x:int[as_sint8(x)]. is_sint8(x) -> as_sint8(x) = x + + +logic as_uint16 :int -> int +predicate is_uint16(x:int) = 0 <= x < 65536 +axiom as_uint16_def : forall x:int. is_uint16(as_uint16(x)) +axiom as_uint16_involve : + forall x:int [as_uint16(as_uint16(x))]. + as_uint16(as_uint16(x)) = as_uint16(x) +axiom is_as_uint16: forall x:int [as_uint16(x)]. is_uint16(x) -> as_uint16(x) = x + +logic as_sint16 :int -> int +predicate is_sint16(x:int) = -32768 <= x < 32768 +axiom as_sint16_def : forall x:int. is_sint16(as_sint16(x)) +axiom as_sint16_involve : + forall x:int [as_sint16(as_sint16(x))]. + as_sint16(as_sint16(x)) = as_sint16(x) +axiom is_as_sint16: forall x:int [as_sint16(x)]. is_sint16(x) -> as_sint16(x) = x + + +logic as_uint32 :int -> int +predicate is_uint32(x:int) = 0 <= x < 4294967296 +axiom as_uint32_def : forall x:int. is_uint32(as_uint32(x)) +axiom as_uint32_involve : + forall x:int [as_uint32(as_uint32(x))]. + as_uint32(as_uint32(x)) = as_uint32(x) +axiom is_as_uint32: forall x:int [as_uint32(x)]. is_uint32(x) -> as_uint32(x) = x + +logic as_sint32 :int -> int +predicate is_sint32(x:int) = -2147483648 <= x < 2147483648 +axiom as_sint32_def : forall x:int. is_sint32(as_sint32(x)) +axiom as_sint32_involve : + forall x:int [as_sint32(as_sint32(x))]. + as_sint32(as_sint32(x)) = as_sint32(x) +axiom is_as_sint32: forall x:int [as_sint32(x)]. is_sint32(x) -> as_sint32(x) = x + + +logic as_uint64 :int -> int +predicate is_uint64(x:int) = 0 <= x < 18446744073709551616 +axiom as_uint64_def : forall x:int. is_uint64(as_uint64(x)) +axiom as_uint64_involve : + forall x:int [as_uint64(as_uint64(x))]. + as_uint64(as_uint64(x)) = as_uint64(x) +axiom is_as_uint64: forall x:int [as_uint64(x)]. is_uint64(x) -> as_uint64(x) = x + +logic as_sint64 :int -> int +predicate is_sint64(x:int) = -9223372036854775808 <= x < 9223372036854775808 +axiom as_sint64_def : forall x:int. is_sint64(as_sint64(x)) +axiom as_sint64_involve : + forall x:int [as_sint64(as_sint64(x))]. + as_sint64(as_sint64(x)) = as_sint64(x) +axiom is_as_sint64: forall x:int [as_sint64(x)]. is_sint64(x) -> as_sint64(x) = x + + +logic as_float16 :real -> real +logic is_float16 :real -> prop +axiom as_float16_def : forall x:real. is_float16(as_float16(x)) +axiom as_float16_involve : + forall x:real [as_float16(as_float16(x))]. + as_float16(as_float16(x)) = as_float16(x) +axiom is_as_float16: forall x:real [as_float16(x)]. is_float16(x) -> as_float16(x) = x + + +logic as_float32 :real -> real +logic is_float32 :real -> prop +axiom as_float32_def : forall x:real. is_float32(as_float32(x)) +axiom as_float32_involve : + forall x:real [as_float32(as_float32(x))]. + as_float32(as_float32(x)) = as_float32(x) +axiom is_as_float32: + forall x:real [as_float32(x)]. is_float32(x) -> as_float32(x) = x + + +logic as_float64 :real -> real +logic is_float64 :real -> prop +axiom as_float64_def : + forall x:real. is_float64(as_float64(x)) +axiom as_float64_involve : + forall x:real [as_float64(as_float64(x))]. + as_float64(as_float64(x)) = as_float64(x) +axiom is_as_float64: + forall x:real [as_float64(x)]. is_float64(x) -> as_float64(x) = x + + +logic as_float128 :real -> real +logic is_float128 :real -> prop +axiom as_float128_def : + forall x:real. is_float128(as_float128(x)) +axiom as_float128_involve : + forall x:real [as_float128(as_float128(x))]. + as_float128(as_float128(x)) = as_float128(x) +axiom is_as_float128: + forall x:real [as_float128(x)]. is_float128(x) -> as_float128(x) = x + +() +( Memory Data Type ) +() + +type data + +logic data_of_uint8: int -> data +logic uint8_of_data: data -> int + +axiom is_uint8_of_data: + forall d:data [is_uint8(uint8_of_data(d))].is_uint8(uint8_of_data(d)) + +axiom uint8ofdata_dataofuint8: + forall x:int [data_of_uint8(x)]. + is_uint8(x) -> uint8_of_data(data_of_uint8(x)) = x + +logic data_of_sint8: int -> data +logic sint8_of_data: data -> int + +axiom is_sint8_of_data: + forall d:data [is_sint8(sint8_of_data(d))]. is_sint8(sint8_of_data(d)) + +axiom sint8ofdata_dataofsint8: + forall x:int [data_of_sint8(x)]. + is_sint8(x) -> sint8_of_data(data_of_sint8(x)) = x + +logic data_of_uint16: int -> data +logic uint16_of_data: data -> int + +axiom is_uint16_of_data: + forall d:data [is_uint16(uint16_of_data(d))]. is_uint16(uint16_of_data(d)) + +axiom uint16ofdata_dataofuint16: + forall x:int [uint16_of_data(data_of_uint16(x))]. + is_uint16(x) -> uint16_of_data(data_of_uint16(x)) = x + +logic data_of_sint16: int -> data +logic sint16_of_data: data -> int + +axiom is_sint16_of_data: + forall d:data [is_sint16(sint16_of_data(d))]. is_sint16(sint16_of_data(d)) + +axiom sint16ofdata_dataofsint16: + forall x:int [data_of_sint16(x)]. + is_sint16(x) -> sint16_of_data(data_of_sint16(x)) = x + +logic data_of_uint32: int -> data +logic uint32_of_data: data -> int + +axiom is_uint32_of_data: + forall d:data [is_uint32(uint32_of_data(d))]. is_uint32(uint32_of_data(d)) + +axiom uint32ofdata_dataofuint32: + forall x:int [data_of_uint32(x)]. + is_uint32(x) -> uint32_of_data(data_of_uint32(x)) = x + +logic data_of_sint32: int -> data +logic sint32_of_data: data -> int + +axiom is_sint32_of_data: + forall d:data [is_sint32(sint32_of_data(d))]. is_sint32(sint32_of_data(d)) + +axiom sint32ofdata_dataofsint32: + forall x:int [data_of_sint32(x)]. + is_sint32(x) -> sint32_of_data(data_of_sint32(x)) = x + +logic data_of_uint64: int -> data +logic uint64_of_data: data -> int + +axiom is_uint64_of_data: + forall d:data [is_uint64(uint64_of_data(d))]. is_uint64(uint64_of_data(d)) + +axiom uint64ofdata_dataofuint64: + forall x:int [data_of_uint64(x)]. + is_uint64(x) -> uint64_of_data(data_of_uint64(x)) = x + +logic data_of_sint64: int -> data +logic sint64_of_data: data -> int + +axiom is_sint64_of_data: + forall d:data [is_sint64(sint64_of_data(d))]. is_sint64(sint64_of_data(d)) + +axiom sint64ofdata_dataofsint64: + forall x:int [data_of_sint64(x)]. + is_sint64(x) -> sint64_of_data(data_of_sint64(x)) = x + +logic data_of_float16: real -> data +logic float16_of_data: data -> real + +axiom is_float16_of_data: + forall d:data [is_float16(float16_of_data(d))]. is_float16(float16_of_data(d)) +axiom float16ofdata_dataoffloat16: + forall x:real [data_of_float16(x)]. + is_float16(x) -> float16_of_data(data_of_float16(x)) = x + +logic data_of_float32: real -> data +logic float32_of_data: data -> real + +axiom is_float32_of_data: + forall d:data [is_float32(float32_of_data(d))]. is_float32(float32_of_data(d)) +axiom float32ofdata_dataoffloat32: + forall x:real [data_of_float32(x)]. + is_float32(x) -> float32_of_data(data_of_float32(x)) = x + +logic data_of_float64: real -> data +logic float64_of_data: data -> real + +axiom is_float64_of_data: + forall d:data [is_float64(float64_of_data(d))]. is_float64(float64_of_data(d)) +axiom float64ofdata_dataoffloat64: + forall x:real [data_of_float64(x)]. + is_float64(x) -> float64_of_data(data_of_float64(x)) = x + +logic data_of_float128: real -> data +logic float128_of_data: data -> real + +axiom is_float128_of_data: + forall d:data [is_float128(float128_of_data(d))]. is_float128(float128_of_data(d)) +axiom float128ofdata_dataoffloat128: + forall x:real [data_of_float128(x)]. + is_float128(x) -> float128_of_data(data_of_float128(x)) = x + + +() +( Update of Arrays over a set of Index *) +(************************************************************************) + + +logic set_range_index: + 'a farray (* array), int set ( set of index), int (uniq key*) -> 'a farray + +axiom set_range_def : + forall t: 'a farray. + forall rg: int set. + forall k:int. + forall i:int [access(set_range_index(t,rg,k),i)]. + not (member(i,rg)) -> + access(set_range_index(t,rg,k),i) = access(t,i) + +(************************************************************************) +(* Bitwise Operations *) +(************************************************************************) + +logic bnot: int -> int +logic band: int,int -> int +logic bor: int,int -> int +logic bxor: int,int -> int +logic lshift: int,int -> int +logic rshift: int,int -> int + +logic int_not: int -> int +logic int_and: int,int -> int +logic int_or: int,int -> int +logic int_xor: int,int -> int +logic int_lsh: int,int -> int +logic int_rshs: int,int -> int +logic int_rshu: int,int -> int +(* ------------------------------------------------------------------------ ) +( --- Store is a basic Load/Store Memory Model --- ) +( ------------------------------------------------------------------------ ) + +( Array theory version's of store memory model (store.why) ) + +logic addr : + int( base address), int( offset) -> int(addr ) + +logic offset : int(addr) -> int(offset) +logic base : int(addr) -> int(base address) + +axiom addr_def: + forall a, b, d: int. + addr(b,d) = a ->(base (a) = b and offset (a) = d ) + +axiom addr_id: + forall p: int [addr(base(p),offset(p))]. + addr(base(p),offset(p)) = p + +logic minus_addr : int (address), int (address) -> int (integer) + +axiom minus_addr_def: + forall a,b:int. + base (a) = base(b) -> minus_addr(a,b) = offset(a) - offset(b) + +predicate addr_lt (a:int,b:int) = + base(a) = base(b) and offset(a) < offset(b) + +function addr_lt_bool (a:int,b:int) : bool = + bool_and ( eq_int_bool(base(a),base(b)) , lt_int_bool( offset(a) , offset(b) ) ) + +predicate addr_le (a:int,b:int) = + base(a) = base(b) and offset(a) <= offset(b) + +function addr_le_bool (a:int,b:int) : bool = + bool_and ( eq_int_bool(base(a),base(b)) , le_int_bool( offset(a) , offset(b) ) ) + +predicate addr_eq (a:int,b:int) = + base(a) = base(b) and offset(a) = offset(b) + +function addr_eq_bool (a:int,b:int) : bool = + bool_and ( eq_int_bool(base(a),base(b)) , eq_int_bool( offset(a) , offset(b) ) ) + + +axiom cmp_null: + forall p:int [addr_eq(p,0)]. p = 0 <-> addr_eq(p,0) + +axiom cmp_null_bool: + forall p:int [addr_eq_bool(p,0)]. p = 0 <-> addr_eq_bool(p,0) = true + +axiom cmp_null_not: + forall p:int. p <> 0 <-> not addr_eq(p,0) + +axiom cmp_null_bool_not: + forall p:int [addr_eq_bool(p,0)]. p <> 0 <-> addr_eq_bool(p,0) = false + + +( ------------------------------------------------------------------------ ) +( --- Decoding Values --- ) +( ------------------------------------------------------------------------ ) + +logic addr_of_data: data -> int +logic data_of_addr: int -> data + +axiom addrofdata_dataofaddr: + forall p:int [data_of_addr(p)]. addr_of_data(data_of_addr(p)) = p + + +( ------------------------------------------------------------------------ ) +( --- Pointer Validity --- ) +( ------------------------------------------------------------------------ ) + +predicate valid (ta: int farray, p:int, n : int ) = + n > 0 -> ( 0 <= offset(p) and offset(p) + n <= access(ta,base(p)) ) + +logic global : int farray -> prop + +(is_fresh is the only relation between a memory state and an allocation + table since we can't specify an unsucced load ) +logic is_fresh : data farray,int farray,int -> prop + + +( a fresh base is different of all valid bases ) +axiom fresh : + forall mem: data farray. ( memory store ) + forall ta,ta': int farray. + forall x,p,n:int [valid(ta',p,n),is_fresh(mem,ta,x)]. + is_fresh(mem,ta,x) -> + ta[x] = 0 -> ( ZD: keep this hypothesis) + access(ta,base(p)) = access(ta',base(p)) -> (help alt-ergo trigger ) + valid(ta',p,n) -> + forall d,sz:int. addr(x,d)<>p + +( a fresh base can't been read in memory ) +axiom fresh_access : + forall mem,mem': data farray. ( memory store ) + forall ta,ta': int farray. + forall b,p,n:int + [is_fresh(mem,ta,b), + valid(ta',p,n), + addr_of_data(access(mem',p))]. + is_fresh(mem,ta,b) -> + ta[b] = 0 -> ( ZD: keep this hypothesis) + valid(ta',p,n) -> + access(ta,base(p)) = access(ta',base(p)) -> (help alt-ergo trigger *) + access(mem,p)=access(mem',p) -> (**) + forall d:int. addr(b,d)<>addr_of_data(access(mem',p)) + + + +function addr_shift (p:int,dofs:int) : int = + addr( base(p),offset(p)+dofs ) + + +(* ------------------------------------------------------------------------ ) +( --- Separated --- ) +( ------------------------------------------------------------------------ ) + + + +predicate separated_on_addr (p:int,p':int, n1: int , n2 : int ) = + base(p) = base(p') -> + offset(p)+n1 <= offset(p') or offset(p) >= offset(p') + n2 +( ------------------------------------------------------------------------ ) +( --- Zone --- ) +( ------------------------------------------------------------------------ ) + +type zone + +logic zrange : int,int,int -> zone +logic zempty : zone +logic zunion : zone,zone -> zone + +logic included : zone,zone -> prop + +logic is_havoc : int farray,data farray,zone,data farray -> prop + +logic is_block : zone -> prop + +axiom is_block_zrange : + forall x,ofs,len : int. + len > 0 -> is_block(zrange(x,ofs,len)) + +axiom is_not_block_zempty : not (is_block(zempty)) + + + + +(ZD: only for pointer on atomic type. ) +function zrange_of_addr (p:int): zone = + zrange( base(p),offset(p),1) + +function zrange_of_addr_range (p:int,dofs:int,n:int) : zone = + zrange( base(p),offset(p)+dofs,n) + +logic separated : zone , zone -> prop + +axiom sep_zrange : + forall b,b',d,d',sz,sz':int[separated(zrange(b,d,sz),zrange(b',d',sz'))]. + separated(zrange(b,d,sz),zrange(b',d',sz')) + <->separated_on_addr(addr(b,d),addr(b',d'),sz,sz') + +axiom separated_sym: + forall z,z': zone. separated(z,z') -> separated(z',z) + +axiom sep_empty : + forall z:zone. separated(zempty,z) + +axiom sep_union: + forall z,z',r: zone [separated(z,zunion(z',r))]. + separated(z,zunion(z',r)) <-> + (separated(z,z') and separated(z,r)) + +( extension of included with empty and union ) + +axiom left_empty : forall z:zone. zunion(z,zempty) = z +axiom right_empty : forall z:zone. zunion(zempty,z) = z +axiom union_same : forall z:zone. zunion(z,z)=z +axiom union_sym : forall z,z':zone. zunion(z,z') = zunion(z',z) +axiom union_assoc : forall z,r,s : zone. + zunion(zunion(z,r),s) = zunion(z,zunion(r,s)) + +axiom inc_range_range : + forall b,d,sz,b',d',sz' : int + [included(zrange(b,d,sz),zrange(b',d',sz'))]. + included(zrange(b,d,sz),zrange(b',d',sz')) <-> + (d<=d+sz -> ( b=b' and d'<= d and d+sz <= d'+sz' )) + +axiom inc_empty : + forall z:zone. included(zempty,z) + +axiom inc_same : + forall z:zone. included(z,z) + +axiom inc_range_empty : + forall b,d,sz:int [ included(zrange(b,d,sz),zempty) ]. + included(zrange(b,d,sz),zempty) <-> b>b+sz + +axiom inc_union_right : + forall z,r,s:zone [included(z,zunion(r,s))]. + (included(z,r) or included(z,s)) -> included(z,zunion(r,s)) + +axiom inc_union_left : + forall s,z,z':zone [included(zunion(s,z'),z)]. + included(s,z) -> included(z',z) -> included(zunion(s,z'),z) + +( ------------------------------------------------------------------------ ) +( --- Access and Update with Ranges --- ) +( ------------------------------------------------------------------------ ) + +logic access_range : data farray,zone -> data +logic update_range : data farray,zone,data -> data farray + +axiom access_update_range_same : + forall m : data farray. + forall z : zone. + forall d : data. + is_block (z) -> + access_range(update_range(m,z,d),z)=d + +axiom access_update_range_sep : + forall m : data farray. + forall v : data. + forall z,z' :zone [access_range(update_range(m,z,v),z')]. + is_block(z) -> is_block(z') -> + separated(z,z') -> + access_range(update_range(m,z,v),z') = access_range(m,z') + +axiom access_range_update_addr_sep: + forall m : data farray. + forall v : data. + forall z:zone. + forall p: int [access_range(update(m,p,v),z)]. + is_block(z) -> + separated(z,zrange_of_addr(p)) -> + access_range(update(m,p,v),z)= access_range(m,z) + +axiom access_update_range_addr_sep : + forall m : data farray. + forall v : data. + forall z: zone. + forall p : int [access(update_range(m,z,v),p)]. + is_block(z) -> + separated(z,zrange_of_addr(p)) -> + access(update_range(m,z,v),p)=access(m,p) + +axiom access_update_sep : + forall m : data farray. + forall v : data. + forall p,q : int [access(update(m,p,v),q)]. + separated(zrange_of_addr(p),zrange_of_addr(q)) -> + access(update(m,p,v),q) = access(m,q) + +( ------------------------------------------------------------------------ ) +( --- Havoc --- ) +( ------------------------------------------------------------------------ ) + +logic update_havoc : data farray,zone,data -> data farray + +( access and is_havoc ) + +axiom load_havoc : + forall m:data farray. + forall v:data. + forall z:zone. + forall p:int [access(update_havoc(m,z,v),p)]. + separated(z,zrange_of_addr(p)) -> + access(update_havoc(m,z,v),p) = access(m,p) + +axiom load_is_havoc : + forall alloc:int farray. + forall mem,mem':data farray. + forall p:int. + forall z:zone [access(mem,p),is_havoc(alloc,mem,z,mem')]. + included(zrange_of_addr(p),z) -> + is_havoc(alloc,mem,z,mem') -> + access(mem',p) = access(mem,p) + +( not assigned is free or in region ) + +logic is_assignable : int farray,zone,zone -> prop + +axiom is_assignable_range_free : + forall alloc:int farray. + forall p:int. + forall z:zone [is_assignable(alloc,zrange_of_addr(p),z)]. + access(alloc,base(p))=0 -> + is_assignable(alloc,zrange_of_addr(p),z) + +axiom is_assignable_included : + forall alloc:int farray. + forall z,z':zone [is_assignable(alloc,z,z')]. + included(z,z') -> is_assignable(alloc,z,z') + +( updates and is_havoc ) + +axiom same_havoc : + forall alloc:int farray. + forall mem:data farray. + forall z:zone. + is_havoc(alloc,mem,z,mem) + +axiom havoc_sym : + forall alloc:int farray. + forall m1, m2:data farray. + forall z:zone. + is_havoc(alloc,m2,z,m1) -> + is_havoc(alloc,m1,z,m2) + +axiom store_havoc : + forall alloc:int farray. + forall mem,mem':data farray. + forall p:int. + forall v:data. + forall z:zone [is_havoc(alloc,mem,z,update(mem',p,v))]. + is_assignable(alloc,zrange_of_addr(p),z) -> + is_havoc(alloc,mem,z,mem') -> + is_havoc(alloc,mem,z,update(mem',p,v)) + +axiom store_havoc_havoc : + forall alloc:int farray. + forall mem,mem':data farray. + forall v:data. + forall z',z:zone [is_havoc(alloc,mem,z,update_havoc(mem',z',v))]. + is_assignable(alloc,z',z) -> + is_havoc(alloc,mem,z,mem') -> + is_havoc(alloc,mem,z,update_havoc(mem',z',v)) + + +axiom store_range_havoc : + forall alloc:int farray. + forall mem,mem':data farray. + forall v:data. + forall z',z:zone [is_havoc(alloc,mem,z,update_range(mem',z',v))]. + is_block(z') -> + is_assignable(alloc,z',z) -> + is_havoc(alloc,mem,z,mem') -> + is_havoc(alloc,mem,z,update_range(mem',z',v)) +(========================================================================) +( Helper Lemmas for Store Model ) +(------------------------------------------------------------------------) + +axiom addr_base: + forall b,d:int. + base(addr(b,d)) = b + +axiom addr_offset: + forall b,d:int. + offset(addr(b,d)) = d + + +axiom base_sep: + forall b,b',d,d':int. + b<>b' -> addr(b,d) <> addr(b',d') + +axiom addr_inj1: + forall b,b',d:int. + b=b' <-> addr(b,d)=addr(b',d) + +axiom addr_inj2: + forall b,d,d':int. + d=d' <-> addr(b,d)=addr(b,d') + + +axiom addr_lt_eq: + forall a:int [addr_lt(a,a)]. not (addr_lt(a,a)) + +axiom addr_le_eq: + forall a:int [addr_le(a,a)]. addr_le(a,a) + +axiom minus_pos_lt : + forall a,b:int [addr_lt(a,b)]. + base(a) = base(b) -> + offset(b) - offset (a) > 0 -> + addr_lt(a,b) + +axiom minus_pos_le : + forall a,b:int [addr_le(a,b)]. + base(a) = base(b) -> + offset(b) - offset (a) >= 0 -> + addr_le(a,b) + +axiom addr_lt_le: + forall a,b:int [addr_le(a,b)]. + addr_lt(a,b) -> addr_le(a,b) + +axiom havoc_union_update_left : + forall alloc:int farray. + forall m,m':data farray. + forall p:int. forall v:data. + forall asgns:zone. + is_havoc (alloc, m, zunion (zrange_of_addr(p) , asgns), m') -> + is_havoc (alloc, m, zunion (zrange_of_addr(p) , asgns), update(m',p, v)) + +axiom havoc_union_update_right : + forall alloc:int farray. + forall m,m':data farray. + forall p:int. forall v:data. + forall z, asgns:zone. + included (zrange_of_addr(p), asgns) -> + is_havoc (alloc, m, zunion (z , asgns), m') -> + is_havoc (alloc, m, zunion (z , asgns), update(m',p, v)) + +axiom havoc_union_update_range_left : + forall alloc:int farray. + forall m,m':data farray. + forall v:data. forall p:int. + forall asgns:zone. + is_havoc (alloc, m, zunion (zrange_of_addr(p) , asgns), m') -> + is_havoc (alloc, m, zunion (zrange_of_addr(p) , asgns), + update_range (m',zrange_of_addr(p), v)) + +axiom havoc_union_update_range_right : + forall alloc:int farray. + forall m,m':data farray. + forall v:data. forall p:int. + forall z, asgns:zone. + included (zrange_of_addr(p), asgns) -> + is_havoc (alloc, m, zunion (z , asgns), m') -> + is_havoc (alloc, m, zunion (z , asgns), + update_range (m',zrange_of_addr(p), v)) + + +axiom inc_union_union : + forall z0,z1,z2,z3: zone. + included(z0,z2) -> included(z1,z3) -> + included(zunion(z0,z1),zunion(z2,z3)) + + +axiom inc_sub_zone: + forall z,z':zone. + included(zunion(zunion(z,z'),zunion(z',z)),zunion(z',z)) + +axiom inc_permut_union: + forall z,z',r: zone. + included (zunion(zunion(z,z'),r),zunion(zunion(z,r),z')) + + +axiom inc_permut2: + forall z,s,r : zone. + included (zunion(zunion(zunion(zunion(z,s),r),r),s) + ,zunion(zunion(z,r),s)) + +axiom union_assoc2: + forall z,z':zone. zunion(z,zunion(z,z'))= zunion(z,z') + + +axiom addr_shift_0: + forall p: int [addr_shift(p,0)]. + addr_shift(p,0) = p + + +axiom addr_shift_shift : + forall p,d,d': int + [addr_shift(addr_shift(p,d),d')]. + addr_shift(addr_shift(p,d),d') = addr_shift(p,d+d') + + +axiom valid_elt : + forall ta:int farray. + forall p,i,n:int. + n > 0 -> + valid(ta,p,n) -> + 0 <= i -> + i +1 <= n -> + valid(ta,addr_shift(p,i),1) + + +axiom separated_on_addr_sym: + forall p,q,n,m:int. + separated_on_addr(p,q,n,m) -> separated_on_addr(q,p,m,n) + +axiom separated_on_addr_inc: + forall b,d,d',sz,sz', b1,d1,sz1 : int. + separated_on_addr(addr(b1,d1),addr(b,d),sz1,sz) -> + d <= d' -> + d'+sz' <= d+sz -> + separated_on_addr(addr(b1,d1),addr(b,d'),sz1,sz') + + +axiom separated_inc : + forall b,d,d',sz,sz', b1,d1,sz1 : int. + separated(zrange(b1,d1,sz1),zrange(b,d,sz)) -> + d <= d' -> + d'+sz' <= d+sz -> + separated(zrange(b1,d1,sz1),zrange(b,d',sz')) + +axiom separated_one_elt: + forall n,m,b,d,sz,b',d',sz' : int. + 0 <n -> 0 < m -> + separated(zrange(b,d,szn),zrange(b',d',sz'm)) -> + forall i,j : int. + 0 <=i -> 0<=j -> + d+i+sz <= d+szn -> + d'+j+sz'<= d'+sz'm -> + separated (zrange(b,d+i,sz),zrange(b',d'+j,sz')) + +axiom store_pointer : + forall x,ofs,y,ofs':int. + separated_on_addr(addr(x,ofs),addr(y,ofs'),1,1) or + addr(x,ofs) = addr(y,ofs') + + + + + +(--------------End of Store Lemmas ---------------------------------*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/share/wp.v frama-c-20111001+nitrogen+dfsg/src/wp/share/wp.v --- frama-c-20110201+carbon+dfsg/src/wp/share/wp.v 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/share/wp.v 2011-10-10 08:38:11.000000000 +0000 @@ -0,0 +1,104 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* + * 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). + ) + +Require Export Bool_nat. +Require Export Zwf. +Require Export ZArith. +Require Export ZArith_dec. +Require Export Zdiv. +Require Import Sumbool. +Require Import Omega. +Require Import ZArithRing. + + +( From WhyCompat ) + +Require Import LegacyRing. +Tactic Notation "ring" constr(t) := legacy ring. +Open Scope Z_scope. + + + +(Why logic) Definition lt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition le_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition gt_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition ge_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition eq_int_bool : Z -> Z -> bool. +Admitted. + +(Why logic) Definition neq_int_bool : Z -> Z -> bool. +Admitted. + +(Why axiom) Lemma lt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((lt_int_bool x y) = true <-> x < y))). +Admitted. + +(Why axiom) Lemma le_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((le_int_bool x y) = true <-> x <= y))). +Admitted. + +(Why axiom) Lemma gt_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((gt_int_bool x y) = true <-> x > y))). +Admitted. + +(Why axiom) Lemma ge_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((ge_int_bool x y) = true <-> x >= y))). +Admitted. + +(Why axiom) Lemma eq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((eq_int_bool x y) = true <-> x = y))). +Admitted. + +(Why axiom) Lemma neq_int_bool_axiom : + (forall (x:Z), (forall (y:Z), ((neq_int_bool x y) = true <-> x <> y))). +Admitted. + +Definition if_then_else (A:Set) (a:bool) (b c:A) := if a then b else c. +Implicit Arguments if_then_else. + +Definition array: Set ->Set. +Admitted. + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/store_mem.ml frama-c-20111001+nitrogen+dfsg/src/wp/store_mem.ml --- frama-c-20110201+carbon+dfsg/src/wp/store_mem.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/store_mem.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,859 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Memory Model with separation ) +( -------------------------------------------------------------------------- ) + +module WpLog = Wp_parameters +open Cil_types +open Formula +open Ctypes +open Clabels + +module Create + (F:Formula.S) + (A:Mint.S with module F = F) + (R:Mfloat.S with module F = F) + = + +struct + + let unsupported = Wp_error.unsupported + + ( ------------------------------------------------------------------------ ) + ( --- Term Types --- ) + ( ------------------------------------------------------------------------ ) + + type decl = F.decl + + + let t_data: tau = Formula.ADT("data",[]) + + type m_memory = m_array + let t_memory : tau = Formula.ADT("farray",[t_data]) + type store = m_memory F.term + + type m_alloc = m_array + let t_alloc : tau = Formula.ADT("farray",[Formula.Integer]) + type alloc = m_alloc F.term + + type m_dzone + type dzone = m_dzone F.term + + + ( ----------------------------------------------------------------------- ) + ( --- Extracted specification from store.why --- ) + ( ----------------------------------------------------------------------- ) + + ( Data and basic typed Data conversions ) + let data_of_int (i: Ctypes.c_int) = + F.e_app1 ((Pretty_utils.sfprintf "data_of_%a") Ctypes.pp_int i) + let int_of_data (i:Ctypes.c_int) = + F.e_app1 ((Pretty_utils.sfprintf "%a_of_data") Ctypes.pp_int i) + let data_of_float (f: Ctypes.c_float) = + F.e_app1 ((Pretty_utils.sfprintf "data_of_%a") Ctypes.pp_float f) + let float_of_data (f:Ctypes.c_float) = + F.e_app1 ((Pretty_utils.sfprintf "%a_of_data") Ctypes.pp_float f) + let addr_of_data = F.e_app1 "addr_of_data" + let data_of_addr = F.e_app1 "data_of_addr" + + + + + + ( Address ) + + let model_addr : F.integer -> F.integer -> F.integer = F.e_app2 "addr" + let model_base : F.integer -> F.integer = F.e_app1 "base" + let model_offset : F.integer -> F.integer = F.e_app1 "offset" + + let model_addr_shift : F.integer -> F.integer -> F.integer = + F.e_app2 "addr_shift" + + + ( Allocation ) + + let model_valid : alloc -> F.integer -> F.integer -> F.pred = + F.p_app3 "valid" + + let model_isfresh : store -> alloc -> F.integer -> F.pred = + F.p_app3 "is_fresh" + + let model_alloc (talloc:alloc) (p:F.integer) (sz:F.integer) : alloc = + F.e_update talloc p (F.wrap sz) + + let model_free (talloc : alloc) (p: F.integer) : alloc = + F.e_update talloc p (F.wrap F.i_zero) + + let model_block (talloc : alloc) (p: F.integer) : F.integer = + F.unwrap (F.e_access talloc p) + + ( Zone ) + + let model_zempty : dzone = F.e_app0 "zempty" + let model_zunion : dzone -> dzone -> dzone = F.e_app2 "zunion" + let model_included : dzone -> dzone -> F.pred = F.p_app2 "included" + + let model_zrange : F.integer -> F.integer -> F.integer -> dzone = + F.e_app3 "zrange" + + let model_zrange_of_addr_range : + F.integer -> F.integer -> F.integer -> dzone = + F.e_app3 "zrange_of_addr_range" + + let model_separated : dzone -> dzone -> F.pred = F.p_app2 "separated" + + ( Record, Array acces, update ) + + let model_update_range: store -> dzone -> F.abstract -> store = + F.e_app3 "update_range" + let model_access_range: store -> dzone -> F.abstract = + F.e_app2 "access_range" + + + let model_update_havoc: store -> dzone -> F.abstract -> store = + F.e_app3 "update_havoc" + let model_ishavoc : alloc -> store -> dzone -> store -> F.pred = + F.p_app4 "is_havoc" + + type mem = { + x_store : F.var ; + x_alloc : F.var ; + store : store ; + alloc : alloc ; + } + + let encode fmt v = F.e_app2 "encode" fmt v + let decode fmt x = F.e_app2 "decode" fmt x + + ( ----------------------------------------------------------------------- ) + ( --- Instanciation of MVALUE and MLOGIC : Store implemantation --- ) + ( ----------------------------------------------------------------------- ) + + let rec sizeof = function + | C_comp cinfo -> + List.fold_left + (fun sz f -> F.i_add sz + (sizeof (object_of f.ftype))) F.i_zero cinfo.cfields + | C_array ainfo -> + begin + match ainfo.arr_flat with + | Some a -> F.i_mult + (sizeof (object_of a.arr_cell)) + (F.e_int64 a.arr_cell_nbr) + | None -> WpLog.not_yet_implemented "[Store] Sizeof unknown-size array" + end + | _ -> F.i_one + + let n_size n te = F.i_mult (sizeof te) n + let add_offset d te k = F.i_add d (n_size k te) + let cardinal a b = F.i_add F.i_one (F.i_sub b a) + + let offset_of_field f = + let rec acc sz l f = + match l with + | [] -> Wp_parameters.fatal "[offset_of_field] not found %s" f.fname + | fi::m -> + if Cil_datatype.Fieldinfo.equal f fi + then sz + else acc (F.i_add sz (sizeof (object_of fi.ftype))) m f + in + acc F.i_zero f.fcomp.cfields f + + + module Model = + struct + + module A=A + module R=R + module F=F + + type st_loc = + { base :F.integer ; + off:F.integer ; + obj : Ctypes.c_object} + + let upd_base l b = {base = b; off=l.off; obj = l.obj} + let upd_off l d = {base = l.base ; off = d ; obj = l.obj} + let upd_obj l cv = {base = l.base ; off = l.off ; obj = cv} + + type loc = + | Loc of st_loc + | Addr of F.integer Ctypes.c_object (address,type) + + let addr = function + | Loc l -> model_addr l.base l.off + | Addr (p,_) -> p + + let base = function + | Loc l -> l.base + | Addr (p,_) -> model_base p + + let offset = function + | Loc l -> l.off + | Addr (p,_) -> model_offset p + + let object_of_loc = function + | Loc l -> l.obj + | Addr (_,cv) -> cv + + let sizeof_loc l = + let size = Ctypes.sizeof_object (object_of_loc l) in + F.e_int64 size + + + let loc_of_term ty p = Addr (F.unwrap p,ty) + let term_of_loc loc = F.wrap (addr loc) + + + + let null = + let null_obj = Ctypes.C_pointer Cil.charType in + Addr (F.i_zero,null_obj) + + let is_null l = F.e_app2 "addr_eq" (addr l) (F.i_zero) + let lt_loc l1 l2 = F.p_app2 "addr_lt" (addr l1) (addr l2) + let le_loc l1 l2 = F.p_app2 "addr_le" (addr l1) (addr l2) + let equal_loc l1 l2 = F.p_app2 "addr_eq" (addr l1) (addr l2) + let lt_loc_bool l1 l2 = F.e_app2 "addr_lt_bool" (addr l1) (addr l2) + let le_loc_bool l1 l2 = F.e_app2 "addr_le_bool" (addr l1) (addr l2) + let equal_loc_bool l1 l2 = F.e_app2 "addr_eq_bool" (addr l1) (addr l2) + + let minus_loc l1 l2 = + F.e_app2 "minus_addr" (addr l1) (addr l2) + + + let cast_loc_to_int _tp loc _ti = addr loc + + let cast_int_to_loc _ti i tp = Addr (i, Ctypes.object_of tp) + + let pp_loc fmt = function + | Loc l -> + Format.fprintf fmt "addr(%a,%a)" + F.pp_term l.base F.pp_term l.off + | Addr(p,_t) -> F.pp_term fmt p + + let tau_of_loc = Formula.Integer + end + + module Globals = F.DRegister + (struct + include F.Varinfo + + let declare x _ = + let pool = F.pool () in + let xa = F.p_fresh pool "ta" (Model t_alloc) in + let sx = sizeof (Ctypes.object_of x.vtype) in + let xk = F.Xindex.get_ind x in + let sa = F.e_access (F.var xa) xk in + let gta = F.p_app1 "global" (F.var xa) in + Axiom (F.p_forall [xa] + (F.p_implies gta (F.p_eq (F.unwrap sa) sx))) + + let section = S_Model_Prop + let prefix = "Alloc" + let basename x = x.vname + let clear () = () + let pp_descr fmt _x = + Format.fprintf fmt "Global allocation table" + end) + + + + + + module Data = + struct + + module V = Datalib.Cvalues(Model) + module L = Datalib.Create(V) + include V + open Model + + type m_of_mem = m_memory + let tau_of_mem = t_memory + + (* ZD : Be carreful, here [dummy_obj] must be useless. ) + let forall_loc pool = + let b = F.p_fresh pool "b" (Model Integer) in + let d = F.p_fresh pool "d" (Model Integer) in + let dummy_obj = Ctypes.C_int (Ctypes.c_char()) in + let l = {base = F.var b ; off = F.var d ; obj = dummy_obj} in + [b;d] , Loc l + + let load_rec = ref (fun _ _ _ -> assert false) + let store_rec = ref (fun _ _ _ _ -> assert false) + + + + let define_vinfo x = + if x.vglob && (Ctypes.no_infinite_array (Ctypes.object_of x.vtype)) + then Globals.define x + + let global = define_vinfo + + let cvar_of_var vinfo = + define_vinfo vinfo ; + Loc + {base = F.Xindex.get_ind vinfo; + off = F.i_zero; + obj = (Ctypes.object_of (vinfo.vtype))} + + let cvar _mem vinfo = cvar_of_var vinfo + + let inner_loc _ = Wp_parameters.fatal "[inner_loc] reserved to funvar" + + let lvar _m lv x = + let ty = + match lv.lv_type with + | Ctype ty -> ty + | ty -> Wp_parameters.fatal + "[lvar] c type of a pure logic type %a" + !Ast_printer.d_logic_type ty + in + loc_of_term (Ctypes.object_of ty)(F.var x) + + let offset loc te n = + if F.equal_terms n F.i_zero then loc else + match loc with + | Loc l -> + Loc (upd_obj (upd_off l (add_offset l.off te n)) te) + | Addr (p,_) -> + Addr(model_addr_shift p (n_size n te),te) + + let shift = offset + let index = offset + + let field loc f = + if f.fcomp.cstruct then + let pos = offset_of_field f in + let cv = Ctypes.object_of f.ftype in + match loc with + | Loc l -> + Loc (upd_obj (upd_off l (F.i_add l.off pos)) cv) + | Addr (p,_) -> Addr (model_addr_shift p pos,cv) + else + unsupported "union field" + + let load_mem m t l = !load_rec m t l + let store_mem m t l v = !store_rec m t l v + + let mem () = + let x_m = L.fresh "m" (Formula.Model t_memory) in + let x_t = L.fresh "ta" (Formula.Model t_alloc) in + { + x_store = x_m ; + x_alloc = x_t ; + store = F.var x_m ; + alloc = F.var x_t ; + } + + end + + module DF = Data_mem.Create(Data) + + include Data + open Model + let startof l _cv = l + + + let base_address _mem = function + | Loc l -> Loc (upd_off l F.i_zero) + | Addr (p,cv) -> Addr(model_addr (model_base p) F.i_zero,cv) + + let block_length _mem loc = sizeof_loc loc + + let cast_loc_to_loc ty1 ty2 l = + let o1 = object_of ty1 in + let o2 = object_of ty2 in + if Ctypes.equal o1 o2 then l else + match o1,o2 with + | C_array ar, C_pointer ty2 -> + if Ctypes.equal (Ctypes.object_of ar.arr_element) (Ctypes.object_of ty2) then + l + else + (match ar.arr_flat with + | Some {Ctypes.arr_cell = ty1} -> + if Ctypes.equal (Ctypes.object_of ty1) (Ctypes.object_of ty2) + then l + else (unsupported "pointer cast from %a to %a " + !Ast_printer.d_type ty1 + !Ast_printer.d_type ty2) + | None -> (unsupported "pointer cast from %a to %a " + !Ast_printer.d_type ty1 + !Ast_printer.d_type ty2) + ) + | _,_ -> (unsupported "pointer cast from %a to %a " + !Ast_printer.d_type ty1 + !Ast_printer.d_type ty2) + + let zrange loc n = + match loc with + | Loc l -> model_zrange l.base l.off n + | Addr (p,_) -> model_zrange_of_addr_range p F.i_zero n + + + + ( ------------------------------------------------------------------------ ) + ( --- Type Coersion Data/Records --- ) + ( ------------------------------------------------------------------------ ) + + ( record of data ) + module SofData = F.DRegister + (struct + include F.Compinfo + let prefix = "SofData" + let section = S_Model_Def + let clear () = () + let pp_title fmt c = + Format.fprintf fmt "SofData for %s '%s'" + (if c.cstruct then "struct" else "union") c.cname + let declare comp _ = + Function ([t_data],Record comp) + end) + + + ( data of record ) + module DataofS = F.DRegister + (struct + include F.Compinfo + let prefix = "DataofS" + let section = S_Model_Def + let clear () = () + let pp_title fmt c = + Format.fprintf fmt "DataofS for %s '%s'" + (if c.cstruct then "struct" else "union") c.cname + let declare comp _ = + Function ([Record comp],t_data) + end) + + let s_of_data comp = F.e_app1 (SofData.get_definition comp).d_name + let data_of_s comp = F.e_app1 (DataofS.get_definition comp).d_name + + ( if is record [comp] s -> record of data (data of record s) = s) + module Ax2SofData = F.DRegister + (struct + include F.Compinfo + let prefix = "SofDataofS" + let section = S_Model_Prop + let clear () = () + let pp_title fmt c = + Format.fprintf fmt "DataofS for %s '%s'" + (if c.cstruct then "struct" else "union") c.cname + let declare comp _ = + let xs = F.p_fresh (F.pool()) "s" (Model (Record comp)) in + let s = F.var xs in + Axiom (F.p_forall [xs] + (F.p_implies (L.is_comp comp s) + (F.p_eq ((s_of_data comp (data_of_s comp s))) s))) + end) + + ( is record [comp] (record [comp] of data d) ) + module Ax3IsSofData = F.DRegister + (struct + include F.Compinfo + let prefix = "ISSofData" + let section = S_Model_Prop + let clear () = () + let pp_title fmt c = + Format.fprintf fmt "IsSofData for %s '%s'" + (if c.cstruct then "struct" else "union") c.cname + let declare comp _ = + let xd = F.p_fresh (F.pool()) "d" (Model t_data) in + let d = F.var xd in + Axiom (F.p_forall [xd] (L.is_comp comp (s_of_data comp d))) + end) + + let coerce_comp comp = + SofData.define comp; DataofS.define comp; + Ax2SofData.define comp; Ax3IsSofData.define comp + + let s_of_data comp = coerce_comp comp ; s_of_data comp + let data_of_s comp = coerce_comp comp ; data_of_s comp + + + ( ------------------------------------------------------------------------ ) + ( --- Type Coersion Data/Arrays --- ) + ( ------------------------------------------------------------------------ ) + + ( arrayof data ) + module AofData = F.DRegister + (struct + include F.Arrayinfo + let prefix = "AofData" + let section = S_Model_Def + let clear () = () + let pp_title fmt arr = + Format.fprintf fmt "AofData for %a " + Ctypes.pretty (C_array arr) + let declare arr _ = + Function ([t_data],Array arr) + end) + + + ( data of array) + module DataofA = F.DRegister + (struct + include F.Arrayinfo + let prefix = "DataofA" + let section = S_Model_Def + let clear () = () + let pp_title fmt arr = + Format.fprintf fmt "DataofA for %a" + Ctypes.pretty (C_array arr) + let declare arr _ = + Function ([Array arr],t_data) + end) + + let a_of_data arr = F.e_app1 (AofData.get_definition arr).d_name + let data_of_a arr = F.e_app1 (DataofA.get_definition arr).d_name + + ( if is array[arr] s -> arrayof data (data of arrays) = s) + module Ax2AofData = F.DRegister + (struct + include F.Arrayinfo + let prefix = "AofDataofA" + let section = S_Model_Prop + let clear () = () + let pp_title fmt arr = + Format.fprintf fmt "DataofA for %a" + Ctypes.pretty (C_array arr) + let declare arr _ = + let xt = F.p_fresh (F.pool()) "t" (Model (Array arr)) in + let t = F.var xt in + Axiom (F.p_forall [xt] + (F.p_implies (L.is_array arr t) + (F.p_eq ((a_of_data arr (data_of_a arr t))) t))) + end) + + ( is array[arr] (array[arr] of data d) ) + module Ax3IsAofData = F.DRegister + (struct + include F.Arrayinfo + let prefix = "IAAofData" + let section = S_Model_Prop + let clear () = () + let pp_title fmt arr = + Format.fprintf fmt "IsAofData for %a" + Ctypes.pretty (C_array arr) + let declare arr _ = + let xd = F.p_fresh (F.pool()) "d" (Model t_data) in + let d = F.var xd in + Axiom (F.p_forall [xd] (L.is_array arr (a_of_data arr d))) + end) + + + let coerce_arr arr = + AofData.define arr; DataofA.define arr; + Ax2AofData.define arr; Ax3IsAofData.define arr + + let a_of_data arr = coerce_arr arr ; a_of_data arr + let data_of_a arr = coerce_arr arr ; data_of_a arr + + + + + ( ------------------------------------------------------------------------ ) + ( --- Lod --- ) + ( ------------------------------------------------------------------------ ) + + + let load_with fmt mem loc = + decode fmt (F.e_access mem (addr loc)) + + let load_mem mem te loc = + match te with + | C_pointer ty -> + let cv = Ctypes.object_of ty in + V_pointer(cv, Addr(addr_of_data (F.e_access mem (addr loc)),cv)) + | C_int i -> + V_int(i,int_of_data i (F.e_access mem (addr loc))) + | C_float f -> + V_float(f, float_of_data f (F.e_access mem (addr loc)) ) + | C_comp comp -> + if comp.cstruct then + let z = zrange loc (sizeof te) in + let d = model_access_range mem z in + V_record(comp,s_of_data comp d) + else Wp_parameters.not_yet_implemented "load of union" + | C_array arr -> + let z = zrange loc (sizeof te) in + let d = model_access_range mem z in + V_array(arr,a_of_data arr d) + + let store_with mem loc fmt v = + F.e_update mem (addr loc) (encode fmt v) + + let store_mem mem te loc v = + match v with + | V_int(i,t) -> F.e_update mem (addr loc) (data_of_int i t) + | V_float(f,t) -> F.e_update mem (addr loc) (data_of_float f t) + | V_pointer(_,lv) -> F.e_update mem (addr loc) (data_of_addr (addr lv)) + | V_record (comp,r) -> + let dr = data_of_s comp r in + let zp = zrange loc (sizeof te) in + model_update_range mem zp dr + | V_union _ -> unsupported "union" + | V_array (arr,r) -> + let dr = data_of_a arr r in + let zp = zrange loc (sizeof te) in + model_update_range mem zp dr + + let () = + begin + Data.load_rec := load_mem ; + Data.store_rec := store_mem ; + end + + let load m te loc = + DF.loaded te ; load_mem m.store te loc + + ( ------------------------------------------------------------------------ ) + ( --- Zone --- ) + ( ------------------------------------------------------------------------ ) + + ( --- Effect Assigns Method --- ) + + let tau_of_dzone = Formula.ADT("zone",[]) + + ( Elementary Zones ) + type assignable = + | Xrange of F.integer F.integer * F.integer (* BASE,OFS,LEN ) + | Arange of F.integer F.integer * F.integer (* ADDR,OFS,LEN ) + | Ablock of F.integer ( ADDR,0,1 ) + + let addr_of_assignable = function + | Xrange(x,ofs,_) -> model_addr x ofs + | Ablock p -> p + | Arange(p,ofs,_sz) -> model_addr_shift p ofs + + let zone_of_assignable = function + | Xrange(x,ofs,sz) -> model_zrange x ofs sz + | Ablock p -> model_zrange_of_addr_range p F.i_zero F.i_one + | Arange(p,ofs,sz) -> model_zrange_of_addr_range p ofs sz + + let assignable_loc te loc = + match loc with + | Loc l -> Xrange(l.base,l.off,sizeof te) + | Addr (p,_) -> Ablock p + + let assignable_range mem te loc rg = + match loc with + | Loc lc -> + begin + match rg with + | {F.inf = Some l ; F.sup = Some h} -> + Xrange(lc.base,add_offset lc.off te l,n_size (cardinal l h) te) + | {F.inf = None ; F.sup = Some h} -> + Xrange(lc.base,lc.off,n_size (F.i_add h F.i_one) te) + | {F.inf = Some l;F.sup = None} -> + let h = + F.i_sub (F.unwrap (F.e_access mem.alloc lc.base)) F.i_one + in + Xrange(lc.base,add_offset lc.off te l,n_size (cardinal l h) te) + | {F.inf = None ; F.sup = None} -> + let h = F.unwrap (F.e_access mem.alloc lc.base) in + Xrange(lc.base,lc.off,n_size h te) + end + | Addr (p,_) -> + begin + match rg with + | {F.inf = Some l;F.sup = Some h} -> + Arange(p,n_size l te,n_size (cardinal l h) te) + | {F.inf = None;F.sup = Some h} -> + Arange(p,F.i_zero,n_size (F.i_add h F.i_one) te) + | {F.inf = Some l ; F.sup = None} -> + let h = + F.i_sub (F.unwrap (F.e_access mem.alloc (model_base p))) + F.i_one + in + Arange(p,n_size l te,n_size (cardinal l h) te) + |{F.inf = None ; F.sup = None} -> + let b = model_base p in + let h = F.unwrap (F.e_access mem.alloc b) in + Xrange(b,F.i_zero,n_size h te) + end + + let assignable m = function + | F.Aloc( te , loc ) -> assignable_loc te loc + | F.Arange( te , loc , rg ) -> assignable_range m te loc rg + + let dzone_assigned m a = zone_of_assignable (assignable m a) + let dzone_subset = model_included + let dzone_union = model_zunion + let dzone_empty () = model_zempty + + let effect_supported = true + + let assignable_sizeof = function + | F.Aloc( te , _ ) -> sizeof te + | F.Arange( te , _ , {F.inf=Some l;F.sup=Some h} ) -> + n_size (cardinal l h) te + | F.Arange _ -> unsupported "infinite range for array" + + let valid mem a = + model_valid mem.alloc + (addr_of_assignable (assignable mem a)) + (assignable_sizeof a) + + let get_zrange_opt = function + | F.Aloc( te , loc ) -> + Some( loc , sizeof te ) + | F.Arange( te , loc , {F.inf=Some a;F.sup=Some b} ) -> + Some( shift loc te a , n_size (cardinal a b) te ) + | F.Arange( te , loc , {F.inf=None;F.sup=Some b} ) -> + Some( loc , n_size (cardinal F.i_zero b) te ) + | _ -> None + + let separated mem a1 a2 = + match get_zrange_opt a1 , get_zrange_opt a2 with + | Some(p,n) , Some(q,m) -> F.p_app4 "separated_on_addr" (addr p) (addr q) n m + | _ -> + model_separated (dzone_assigned mem a1) (dzone_assigned mem a2) + + ( ----------------------------------------------------------------------- ) + ( --- Instanciation of MWP : WP Calculus --- ) + ( ----------------------------------------------------------------------- ) + + let update ~(at:mem) ~(here:mem) p = + L.subst at.x_store here.store + (L.subst at.x_alloc here.alloc p) + + let quantify m p = + L.forall [m.x_store;m.x_alloc] p + + let subst_lval m te loc v p = + DF.stored te ; + L.subst m.x_store (store_mem m.store te loc v) p + + let alloc_vars m xs p = + List.fold_left + (fun p x -> + let v_x = F.Xindex.get_ind x in + let sz_x = sizeof (object_of x.vtype) in + L.subst m.x_alloc (model_alloc m.alloc v_x sz_x) p + ) p xs + + let free_vars m xs p = + List.fold_left + (fun p x -> + let v_x = F.Xindex.get_ind x in + L.subst m.x_alloc (model_free m.alloc v_x) p + ) p xs + + let fresh_vars m xs p = + List.fold_left + (fun p x -> + let v_x = F.Xindex.get_ind x in + let q = model_isfresh m.store m.alloc v_x in + F.p_implies q p + ) p xs + + let notexists_vars m xs p = + List.fold_left + (fun p x -> + let v_x = F.Xindex.get_ind x in + let q = F.p_eq (F.unwrap(F.e_access m.alloc v_x)) F.i_zero in + F.p_implies q p + ) p xs + + let global_scope m p = + if L.has_context_vars [m.x_alloc] p + then F.p_implies (F.p_app1 "global" m.alloc) p + else p + + let filter_scope p vars = + List.filter (fun x -> F.Xindex.has_ind x p) vars + + let local_scope m vars scope p = + match scope with + | Mcfg.SC_Function_frame -> ( nothing to do ) p + | Mcfg.SC_Block_in | Mcfg.SC_Function_in -> + let vars = filter_scope p vars in + notexists_vars m vars + (fresh_vars m vars + (alloc_vars m vars p)) + | Mcfg.SC_Block_out | Mcfg.SC_Function_out -> + let vars = filter_scope p vars in + free_vars m vars + (fresh_vars m vars p) + | Mcfg.SC_Global -> + if L.has_context_vars [m.x_alloc] p + then F.p_implies (F.p_app1 "global" m.alloc) p + else p + + let subst_havoc m a = + let addr = zone_of_assignable (assignable m a) in + let v = L.fresh "v" (Formula.Model(ADT("data",[]))) in + let km sigma = + let m0 = L.apply sigma m.store in + F.wrap(model_update_havoc m0 addr (F.var v)) + in + [F.Fresh v;F.Update(m.x_store,km)] + + let rec region m = function + | [] -> model_zempty + | [a] -> dzone_assigned m a + | a :: others -> model_zunion (dzone_assigned m a) (region m others) + + let assigns_goal m1 assigned m2 = + model_ishavoc m1.alloc m1.store (region m1 assigned) m2.store + + let assigns_supported = true + + ( ----------------------------------------------------------------------- ) + ( --- User Predicate environment --- ) + ( ----------------------------------------------------------------------- ) + + type closure = Mem | Alloc + + let pp_closure fmt = function + | Mem -> Format.fprintf fmt "memory store" + | Alloc -> Format.fprintf fmt "allocation table" + + let userdef_mem_signature m = [ m.x_store,Mem ; m.x_alloc,Alloc ] + + let userdef_mem_apply mem = function + | Mem -> F.wrap mem.store + | Alloc -> F.wrap mem.alloc + + ( ------------------------------------------------------------------------ ) + ( --- Functional Closure --- ) + ( ------------------------------------------------------------------------ ) + + type formal = unit + let pp_formal (_:Format.formatter) _ = () + let userdef_is_ref_param (_:logic_var) : bool = false + let userdef_ref_signature (_:mem) :( F.var logic_var * formal ) list = [] + let userdef_ref_apply (_:mem) (_:formal) (_:loc) : value = + Wp_parameters.fatal "[userdef_ref_apply] of model Store" + let userdef_ref_has_cvar (_ : logic_var) : bool = false + + +end + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/store_mem.mli frama-c-20111001+nitrogen+dfsg/src/wp/store_mem.mli --- frama-c-20110201+carbon+dfsg/src/wp/store_mem.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/store_mem.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,34 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( ) +() + +module Create + (F:Formula.S) + (A:Mint.S with module F = F) + (R:Mfloat.S with module F = F) + : +sig + + include Mwp.S with module F = F + and module A = A + and module R = R + +end diff -Nru frama-c-20110201+carbon+dfsg/src/wp/translate_expr.ml frama-c-20111001+nitrogen+dfsg/src/wp/translate_expr.ml --- frama-c-20110201+carbon+dfsg/src/wp/translate_expr.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/translate_expr.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,787 @@ +() +( ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- Translation of Expressions --- ) +( -------------------------------------------------------------------------- ) + +open Ctypes +open Cil_types +open Cil_datatype +module WpLog = Wp_parameters + + +let dkey = "translate_exp" ( debugging key) + +let debug = Wp_parameters.debug ~dkey + + +module Create (M:Mvalues.S) = +struct + + module F = M.F + module A = M.A + module R = M.R + + (------------------------------------------------------------------------ ) + (--- Utilities --- ) + (------------------------------------------------------------------------ ) + + let c_int_of_typ t = + match object_of t with + | C_int i -> i + | _ -> WpLog.fatal "non-integer offset" + + + let int_of_value = function + | M.V_int(_,t) -> t + | v -> WpLog.fatal "[int_of_value] of non integer value %a" M.pp_value v + + let float_of_value = function + | M.V_float(_,t) -> t + | v -> WpLog.fatal "[float_of_value] of non float value %a" M.pp_value v + + let loc_of_value = function + | M.V_pointer(_,loc) -> loc + | M.V_array _ as v -> + debug "[loc_of_value] ARRAY %a" M.pp_value v ; + WpLog.fatal "[loc_of_value] ARRAY %a" M.pp_value v + | v -> debug "[loc_of_value] %a" M.pp_value v ; + WpLog.fatal "[loc_of_value] %a" M.pp_value v + + let value_of_integer i z = M.V_int(i,z) + let value_of_boolean b = value_of_integer (Ctypes.c_bool()) (F.e_bool b) + let boolean_of_loc p = F.e_not (M.is_null p) + let boolean_of_integer z = F.e_icmp Formula.Cneq z F.i_zero + let boolean_of_int v = boolean_of_integer v + let boolean_of_float v = F.e_rcmp Formula.Cneq v F.r_zero + + let boolean_of_value = function + | M.V_int(_,t) -> boolean_of_int t + | M.V_float(_,t) -> boolean_of_float t + | M.V_pointer(_,loc) -> boolean_of_loc loc + | v -> WpLog.fatal "[loc_of_value] %a"M.pp_value v + + let prop_of_loc p = F.p_not (F.p_bool (M.is_null p)) + let prop_of_integer z = F.p_icmp Formula.Cneq z F.i_zero + let prop_of_int z = prop_of_integer z + let prop_of_float r = F.p_rcmp Formula.Cneq r F.r_zero + + let prop_of_value = function + | M.V_int(_,t) -> prop_of_int t + | M.V_float(_,t) -> prop_of_float t + | M.V_pointer(_,loc) -> prop_of_loc loc + | v -> WpLog.fatal "[prop_of_value] %a" M.pp_value v + + let not_of_loc p = F.p_bool (M.is_null p) + let not_of_integer z = F.p_icmp Formula.Ceq z F.i_zero + let not_of_int z = not_of_integer z + let not_of_float r = F.p_rcmp Formula.Ceq r F.r_zero + + let not_of_value = function + | M.V_int(_,t) -> not_of_int t + | M.V_float(_,t) -> not_of_float t + | M.V_pointer(_,loc) -> not_of_loc loc + | v -> WpLog.fatal "[not_of_value] %a" M.pp_value v + + ( ----------------------------------------------------------------------- ) + ( --- Deep Recursion over Expressions, Conditions and binary operators -- ) + ( ----------------------------------------------------------------------- ) + + let expr_rec = ref (fun _ _ -> assert false) + let cond_rec = ref (fun _ _ -> assert false) + + let prop_rec = ref (fun _ _ -> assert false) + + ( [expr_int mem ie ir e] interprets an expression [e] in the memory + [mem] as an integer of size [ie] and converts this integer as an + integer of size [ir]. ) + let expr_int mem ie ir e = + F.i_convert ie ir (int_of_value (!expr_rec mem e)) + + ( [expr_float mem fe fr e] interprets an expression [e] in the + memory [mem] as a float of size [fe] and converts this float as a + float of size [fr]. ) + let expr_float mem _fe _fr e = + (float_of_value (!expr_rec mem e)) + + ( ----------------------------------------------------------------------- ) + ( --- Casts --- ) + ( ----------------------------------------------------------------------- ) + + ([expr_cast tyv tyr v] converts a value [v] of type [tyv] to type + [tyr].) + let expr_cast tyv tyr v = + if Typ.equal tyv tyr then v else + match object_of tyv, object_of tyr with + | C_int i1 , C_int i2 -> + M.V_int(i2,F.i_convert i1 i2 (int_of_value v)) + | C_float _f1 , C_float f2 -> + M.V_float(f2,float_of_value v) + | C_int _ , C_float f2 -> + let z = int_of_value v in + let r = F.real_of_integer z in + M.V_float(f2,r) + | C_float _ , C_int i2 -> + let r = float_of_value v in + let z = F.integer_of_real r in + M.V_int(i2,M.F.modulo i2 z) + ( TODO : specify non-modulo Cf. ISO-C 6.3.1.4 ) + | C_pointer t1 , C_pointer t2 -> + M.V_pointer + (Ctypes.object_of t2, + M.cast_loc_to_loc t1 t2 (loc_of_value v)) + | C_pointer t1 , C_int i2 -> + M.V_int (i2,M.cast_loc_to_int t1 (loc_of_value v)i2) + | C_int i1 , C_pointer t2 -> + M.V_pointer + (Ctypes.object_of t2, + M.cast_int_to_loc i1 (int_of_value v) t2) + | a,b -> + WpLog.not_yet_implemented "cast from %a to %a" + pp_object a pp_object b + + let prop_cast tyv tyr v = + match object_of tyv , object_of tyr with + | C_int i1 , C_int i2 -> + prop_of_int (F.i_convert i1 i2 (int_of_value v)) + | C_float _f1 , C_float _f2 -> + prop_of_float (float_of_value v) + | C_int _i1 , C_float _ -> + let z = int_of_value v in + let r = F.real_of_integer z in + prop_of_float r + | C_float _ , C_int i2 -> + let r = float_of_value v in + let z = F.integer_of_real r in + prop_of_int (F.modulo i2 z) + ( TODO : specify non-modulo Cf. ISO-C 6.3.1.4 ) + | C_pointer t1 , C_pointer t2 -> + prop_of_loc (M.cast_loc_to_loc t1 t2 (loc_of_value v)) + | C_pointer t1 , C_int i2 -> + prop_of_int (M.cast_loc_to_int t1 (loc_of_value v) i2) + | C_int i1 , C_pointer t2 -> + prop_of_loc (M.cast_int_to_loc i1 (int_of_value v) t2) + | a,b -> + WpLog.not_yet_implemented "cast from %a to %a" + pp_object a pp_object b + + + + ( ----------------------------------------------------------------------- ) + ( --- Constants --- ) + ( ----------------------------------------------------------------------- ) + + ( [expr_const m c] interprets a constant [c] in memory [m].) + let expr_const mem = function + | CInt64(k,ik,_) -> + M.V_int(Ctypes.c_int ik,F.e_icst (My_bigint.to_string k)) + | CChr c -> + M.V_int(Ctypes.c_char (),F.e_icst (Int64.to_string (Ctypes.char c))) + | CReal(f,fk,_) -> + M.V_float(Ctypes.c_float fk, F.e_float f) + | CEnum e -> + !expr_rec mem e.eival + | CWStr _ -> + WpLog.not_yet_implemented "wide character string constant" + | CStr s -> + WpLog.not_yet_implemented "character string constant (%S)" s + + let prop_const mem = function + | CInt64(k,_,_) -> + if My_bigint.equal k My_bigint.zero then F.p_false else F.p_true + | CChr c -> + if c ='0' then F.p_false else F.p_true + | CReal(f,_,_) -> + if f = 0.0 then F.p_false else F.p_true + | CEnum e -> + !prop_rec mem e.eival + | CWStr _ -> F.p_false ( pointer to constant string is non-null ) + | CStr _ -> F.p_false ( pointer to constant string is non-null ) + + ( ----------------------------------------------------------------------- ) + ( --- Address --- ) + ( ----------------------------------------------------------------------- ) + + ( [shift_loc mem l typ_l path] interprets [path] in memory [mem] from + the location [l] of type [typ_l]. ) + let rec shift_loc (mem:M.mem) l typ_l = function + | NoOffset -> l + | Field(f,next) -> + shift_loc mem (M.field l f) f.ftype next + | Index(e,next) -> + let v = !expr_rec mem e in + let k = int_of_value v in + let typ_elt = Cil.typeOf_array_elem typ_l in + shift_loc mem (M.index l (Ctypes.object_of typ_elt) k) typ_elt next + + let typeOf_array_elem = function + | C_array arr -> object_of arr.arr_element + | t -> WpLog.fatal + "[typeOf_array_elem] of non array type %a" Ctypes.pp_object t + + ( [addr mem l] interprets the left-value [l] as memory path + (address) in the memory of [mem].) + let addr mem l = + match l with + | (Var x,off) -> + let te = x.vtype in + shift_loc mem (M.cvar mem x) te off + | (Mem e,off) -> + let te = Cil.typeOf e in + let tl = Cil.typeOf_pointed te in + let loc = loc_of_value (!expr_rec mem e) in + shift_loc mem loc tl off + + ( [startof mem t_elt lv] compute the location of l-value [lv], casted + as pointer to an object of type [t] ) + let startof mem t_elt lv = + M.startof (addr mem lv) t_elt + + ( ---------------------------------------------------------------------- ) + ( --- Binary Expressions --- ) + ( ---------------------------------------------------------------------- ) + + let int_operator iota = function + | PlusA -> A.i_op iota Formula.Iadd + | MinusA -> A.i_op iota Formula.Isub + | Mult -> A.i_op iota Formula.Imul + | Div -> A.i_op iota Formula.Idiv + | Mod -> A.i_op iota Formula.Imod + | BAnd -> A.bits_and iota + | BXor -> A.bits_xor iota + | BOr -> A.bits_or iota + | Shiftlt -> A.bits_lshift iota + | Shiftrt -> A.bits_rshift iota + | _ -> WpLog.fatal "[int_operator] non integer operator" + + let float_operator phi = function + | PlusA -> R.f_op phi Formula.Radd + | MinusA -> R.f_op phi Formula.Rsub + | Mult -> R.f_op phi Formula.Rmul + | Div -> R.f_op phi Formula.Rdiv + | _ -> WpLog.fatal "[float_operator] non float operator" + + let icmp_operator iota op x y = + match op with + | Eq -> A.i_cmp iota Formula.Ceq x y + | Ne -> A.i_cmp iota Formula.Cneq x y + | Lt -> A.i_cmp iota Formula.Clt x y + | Le -> A.i_cmp iota Formula.Cleq x y + | Ge -> A.i_cmp iota Formula.Cleq y x + | Gt -> A.i_cmp iota Formula.Clt y x + | _ -> WpLog.fatal "[icmp_operator] non integer comparator" + + let prop_icmp op x y = + match op with + | Eq -> F.p_icmp Formula.Ceq x y + | Ne -> F.p_icmp Formula.Cneq x y + | Lt -> F.p_icmp Formula.Clt x y + | Le -> F.p_icmp Formula.Cleq x y + | Ge -> F.p_icmp Formula.Cleq y x + | Gt -> F.p_icmp Formula.Clt y x + | _ -> WpLog.fatal "[prop_icmp] non integer relation" + + let fcmp_operator phi op x y = + match op with + | Eq -> R.f_cmp phi Formula.Ceq x y + | Ne -> R.f_cmp phi Formula.Cneq x y + | Lt -> R.f_cmp phi Formula.Clt x y + | Le -> R.f_cmp phi Formula.Cleq x y + | Ge -> R.f_cmp phi Formula.Cleq y x + | Gt -> R.f_cmp phi Formula.Clt y x + | _ -> WpLog.fatal "[fcmp_operator] non float comparator" + + let prop_rcmp op x y = + match op with + | Eq -> F.p_rcmp Formula.Ceq x y + | Ne -> F.p_rcmp Formula.Cneq x y + | Lt -> F.p_rcmp Formula.Clt x y + | Le -> F.p_rcmp Formula.Cleq x y + | Ge -> F.p_rcmp Formula.Cleq y x + | Gt -> F.p_rcmp Formula.Clt y x + | _ -> WpLog.fatal "[prop_rcmp] non real relation" + + + let pcmp_operator op x y = + match op with + | Eq -> M.equal_loc_bool x y + | Ne -> F.e_not ( M.equal_loc_bool x y) + | Lt -> M.lt_loc_bool x y + | Le -> M.le_loc_bool x y + | Ge -> M.le_loc_bool y x + | Gt -> M.lt_loc_bool y x + | _ -> WpLog.fatal "[pcmp_operator] non comparator" + + + let pcmp_rel op x y = + match op with + | Eq -> M.equal_loc x y + | Ne -> F.p_not (M.equal_loc x y) + | Lt -> M.lt_loc x y + | Le -> M.le_loc x y + | Ge -> M.le_loc y x + | Gt -> M.lt_loc y x + | _ -> WpLog.fatal "[pcmp_rel] non relation" + + ( special pointer arithmetic interpretation of Zero. ) + let expr_rec_spec_null mem e1 = + if Cil.isZero e1 then + let t = Ctypes.object_of (Cil.typeOf e1) in + M.V_pointer(t, M.null) else (!expr_rec mem e1) + + (Interpretation of pointer comparisons. ) + let expr_cond_cmp_ptr mem cmpop e1 e2 = + let t1 = loc_of_value (expr_rec_spec_null mem e1) in + let t2 = loc_of_value (expr_rec_spec_null mem e2) in + pcmp_operator cmpop t1 t2 + + let prop_cmp_ptr mem cmpop e1 e2 = + let t1 = loc_of_value (expr_rec_spec_null mem e1) in + let t2 = loc_of_value (expr_rec_spec_null mem e2) in + pcmp_rel cmpop t1 t2 + + (Interpretation of arithmetic comparisons. ) + let expr_cond_cmp_arith mem cmpop ct1 e1 ct2 e2 = + let ctr = Ctypes.promote ct1 ct2 in + begin + match ctr , ct1 , ct2 with + | C_int ir , C_int i1 , C_int i2 -> + let t1 = expr_int mem i1 ir e1 in + let t2 = expr_int mem i2 ir e2 in + icmp_operator ir cmpop t1 t2 + | C_float fr, C_float f1, C_float f2 -> + let t1 = expr_float mem f1 fr e1 in + let t2 = expr_float mem f2 fr e2 in + fcmp_operator fr cmpop t1 t2 + | _ -> WpLog.fatal "[expr_cond_cmp_arith] non arithmetics comparison" + end + + ( [expr_cond_cmp mem cmpop t1 e1 t2 e2] returns the interpreation + of the comparison [cmpop] of expression [e1] of type [t1] and + expression [e2] of type [t2] in memory [mem]. ) + let expr_cond_cmp mem cmpop t1 e1 t2 e2 = + let ct1 = Ctypes.object_of t1 in + let ct2 = Ctypes.object_of t2 in + begin + match ct1,ct2 with + | C_pointer _,C_pointer _ -> expr_cond_cmp_ptr mem cmpop e1 e2 + | _ -> expr_cond_cmp_arith mem cmpop ct1 e1 ct2 e2 + end + + + + let prop_cmp mem cmpop t1 e1 t2 e2 = + let ct1 = Ctypes.object_of t1 in + let ct2 = Ctypes.object_of t2 in + match ct1,ct2 with + | C_pointer _,C_pointer _ -> + (prop_cmp_ptr mem cmpop e1 e2) + | _ -> + let ctr = Ctypes.promote ct1 ct2 in + begin + match ctr , ct1 , ct2 with + | C_int ir , C_int i1 , C_int i2 -> + let t1 = expr_int mem i1 ir e1 in + let t2 = expr_int mem i2 ir e2 in + prop_icmp cmpop t1 t2 + | C_float fr, C_float f1, C_float f2 -> + let t1 = expr_float mem f1 fr e1 in + let t2 = expr_float mem f2 fr e2 in + prop_rcmp cmpop t1 t2 + | _ -> WpLog.fatal "[prop_cmp] non arithmetic relation" + end + + ( Interpretation of integer arithmetics. ) + let expr_int_operator mem ir binop i1 e1 i2 e2 = + let t1 = expr_int mem i1 ir e1 in + let t2 = expr_int mem i2 ir e2 in + int_operator ir binop t1 t2 + + + ( Interpretation of float arithmetics ) + let expr_float_operator mem fr binop f1 e1 f2 e2 = + let t1 = expr_float mem f1 fr e1 in + let t2 = expr_float mem f2 fr e2 in + float_operator fr binop t1 t2 + + + ( [expr_binop mem binop tr e1 t1 e2 t2] interprets the binary + operation [binop] as a value of type [tr] of expression [e1] of + type [t1] and expression [e2] of type [t2].) + let expr_binop mem binop tr e1 t1 e2 t2 = + match binop with + | IndexPI | PlusPI -> + let ty = Ctypes.object_of_pointed (Ctypes.object_of t1) in + let loc = loc_of_value (!expr_rec mem e1) in + let idx = int_of_value (!expr_rec mem e2) in + M.V_pointer(ty,M.shift loc ty idx) + + | MinusPI -> + let ty = Ctypes.object_of_pointed (Ctypes.object_of t1) in + let loc = loc_of_value (!expr_rec mem e1) in + let neg_idx = int_of_value (!expr_rec mem e2) in + let idx = F.e_ineg neg_idx in + M.V_pointer(ty,M.shift loc ty idx) + + | MinusPP -> + let iota = c_int_of_typ tr in + value_of_integer iota + (M.minus_loc + (loc_of_value (!expr_rec mem e1)) + (loc_of_value (!expr_rec mem e2))) + + | (Eq | Ne | Ge | Le | Gt | Lt) -> + value_of_boolean (expr_cond_cmp mem binop t1 e1 t2 e2) + + | PlusA | MinusA | Mult | Div | Mod + | BAnd | BXor | BOr | Shiftlt | Shiftrt -> + let ct1 = Ctypes.object_of t1 in + let ct2 = Ctypes.object_of t2 in + let ctr = Ctypes.object_of tr in + begin + match ctr , ct1 , ct2 with + | C_int ir , C_int i1 , C_int i2 -> + M.V_int(ir,expr_int_operator mem ir binop i1 e1 i2 e2) + | C_float fr, C_float f1, C_float f2 -> + M.V_float(fr,expr_float_operator mem fr binop f1 e1 f2 e2) + | _ -> WpLog.fatal "non arithmetics arguments" + end + + | LAnd -> + value_of_boolean (F.e_and (!cond_rec mem e1) (!cond_rec mem e2)) + | LOr -> + value_of_boolean (F.e_or (!cond_rec mem e1) (!cond_rec mem e2)) + + ( [cond_binop mem binop tr e1 t1 e2 t2] interprets the binary + operation [binop] as a boolean of expression [e1] of type [t1] + and expression [e2] of type [t2].) + let cond_binop mem binop tr e1 t1 e2 t2 = + match binop with + | IndexPI | PlusPI -> + let te = Ctypes.object_of_pointed (Ctypes.object_of t1) in + let loc = loc_of_value (!expr_rec mem e1) in + let idx = int_of_value (!expr_rec mem e2) in + boolean_of_loc (M.shift loc te idx) + + | MinusPI -> + let te = Ctypes.object_of_pointed (Ctypes.object_of t1) in + let loc = loc_of_value (!expr_rec mem e1) in + let neg_idx = int_of_value (!expr_rec mem e2) in + let idx = F.e_ineg neg_idx in + boolean_of_loc (M.shift loc te idx) + + | MinusPP -> + boolean_of_integer + (M.minus_loc + (loc_of_value (!expr_rec mem e1)) + (loc_of_value (!expr_rec mem e2))) + + | (Eq | Ne | Ge | Le | Gt | Lt) -> + expr_cond_cmp mem binop t1 e1 t2 e2 + + | PlusA | MinusA | Mult | Div | Mod + | BAnd | BXor | BOr | Shiftlt | Shiftrt -> + let ct1 = Ctypes.object_of t1 in + let ct2 = Ctypes.object_of t2 in + let ctr = Ctypes.object_of tr in + begin + match ctr , ct1 , ct2 with + | C_int ir , C_int i1 , C_int i2 -> + boolean_of_int (expr_int_operator mem ir binop i1 e1 i2 e2) + | C_float fr, C_float f1, C_float f2 -> + boolean_of_float + (expr_float_operator mem fr binop f1 e1 f2 e2) + | _ -> WpLog.fatal "non arithmetics arguments" + end + + | LAnd -> F.e_and (!cond_rec mem e1) (!cond_rec mem e2) + | LOr -> F.e_or (!cond_rec mem e1) (!cond_rec mem e2) + + + let prop_binop mem binop tr e1 t1 e2 t2 = + match binop with + | IndexPI | PlusPI -> + let te = Ctypes.object_of_pointed (Ctypes.object_of t1) in + let loc = loc_of_value (!expr_rec mem e1) in + let idx = int_of_value (!expr_rec mem e2) in + prop_of_loc (M.shift loc te idx) + + | MinusPI -> + let te = Ctypes.object_of_pointed (Ctypes.object_of t1) in + let loc = loc_of_value (!expr_rec mem e1) in + let neg_idx = int_of_value (!expr_rec mem e2) in + let idx = F.e_ineg neg_idx in + prop_of_loc (M.shift loc te idx) + + | MinusPP -> + prop_of_integer + (M.minus_loc + (loc_of_value (!expr_rec mem e1)) + (loc_of_value (!expr_rec mem e2))) + + | (Eq | Ne | Ge | Le | Gt | Lt) -> + prop_cmp mem binop t1 e1 t2 e2 + + | PlusA | MinusA | Mult | Div | Mod + | BAnd | BXor | BOr | Shiftlt | Shiftrt -> + let ct1 = Ctypes.object_of t1 in + let ct2 = Ctypes.object_of t2 in + let ctr = Ctypes.object_of tr in + begin + match ctr , ct1 , ct2 with + | C_int ir , C_int i1 , C_int i2 -> + prop_of_int (expr_int_operator mem ir binop i1 e1 i2 e2) + | C_float fr, C_float f1, C_float f2 -> + prop_of_float + (expr_float_operator mem fr binop f1 e1 f2 e2) + | _ -> WpLog.fatal "non arithmetics arguments" + end + + | LAnd -> F.p_and (!prop_rec mem e1) (!prop_rec mem e2) + | LOr -> F.p_or (!prop_rec mem e1) (!prop_rec mem e2) + + + ( ----------------------------------------------------------------------- ) + ( --- Unary Operator --- ) + ( ----------------------------------------------------------------------- ) + + ( [cond_unop mem op tyr e te ] interprets the unary operation [op] + as a boolean of expression [e] of type [te].) + let cond_unop mem op tyr e te = + let ct1 = object_of te in + let ctr = object_of tyr in + match op with + | Neg -> + begin + match ctr,ct1 with + | C_int ir , C_int i1 -> + boolean_of_int (A.i_neg ir (expr_int mem i1 ir e)) + | C_float fr , C_float f1 -> + boolean_of_float (R.f_neg fr (expr_float mem f1 fr e)) + | _ ->WpLog.fatal "non arithmetics argument" + end + | BNot -> + begin + match ctr,ct1 with + | C_int ir , C_int i1 -> + boolean_of_int (A.bits_not ir (expr_int mem i1 ir e)) + | _ -> WpLog.fatal "non integer argument" + end + | LNot -> + let term = !expr_rec mem e in + begin + match ct1 with + | C_int i1 -> + (A.i_cmp i1 Formula.Ceq (int_of_value term) F.i_zero) + | C_float f1 -> + (R.f_cmp f1 Formula.Ceq (float_of_value term) F.r_zero) + | C_pointer _ -> + (M.is_null (loc_of_value term)) + | _ -> WpLog.fatal "non arithmetics nor pointer argument" + + end + + ( [expr_unop mem op tyr e te ] interprets the unary operation [op] + as a value of type [tyr] of expression [e] of type [te].) + let expr_unop mem op tyr e te = + let ct1 = object_of te in + let ctr = object_of tyr in + match op with + | Neg -> + begin + match ctr,ct1 with + | C_int ir , C_int i1 -> + M.V_int(ir,A.i_neg ir (expr_int mem i1 ir e)) + | C_float fr , C_float f1 -> + M.V_float(fr,R.f_neg fr (expr_float mem f1 fr e)) + | _ -> WpLog.fatal "non arithmetic argument" + end + | BNot -> + begin + match ctr,ct1 with + | C_int ir , C_int i1 -> + M.V_int(ir,expr_int mem i1 ir e) + | _ -> WpLog.fatal "non intger argument" + end + | LNot -> + let term = !expr_rec mem e in + begin + match ct1 with + | C_int i1 -> + value_of_boolean (A.i_cmp i1 Formula.Ceq + (int_of_value term) F.i_zero) + | C_float f1 -> + value_of_boolean (R.f_cmp f1 Formula.Ceq + (float_of_value term) F.r_zero) + | C_pointer _ -> + value_of_boolean + (M.is_null (loc_of_value term)) + | _ -> WpLog.fatal "non arithmetic nor pointer argument" + end + + let prop_unop mem op tyr e te = + let ct1 = object_of te in + let ctr = object_of tyr in + match op with + | Neg -> + begin + match ctr,ct1 with + | C_int ir , C_int i1 -> + prop_of_int (A.i_neg ir (expr_int mem i1 ir e)) + | C_float fr , C_float f1 -> + prop_of_float (R.f_neg fr (expr_float mem f1 fr e)) + | _ -> WpLog.fatal "non arithmetic argument" + end + | BNot -> + begin + match ctr,ct1 with + | C_int ir , C_int i1 -> not_of_int (expr_int mem i1 ir e) + | _ -> WpLog.fatal "non integer argument" + end + | LNot -> let term = !expr_rec mem e in not_of_value term + + ( ----------------------------------------------------------------------- ) + ( --- Expressions --- ) + ( ----------------------------------------------------------------------- ) + + let rec expr mem e = + match (Cil.stripInfo e).enode with + | Info _ -> WpLog.fatal "non translation for info type expression" + | Const (cnst) -> expr_const mem cnst + | CastE (ty,e) -> + if Cil.isPointerType ty && Cil.isZero e then + (let t = Ctypes.object_of_pointed (Ctypes.object_of ty) in + M.V_pointer(t, M.null)) + else + expr_cast (Cil.typeOf e) ty (expr mem e) + | BinOp (op, e1, e2, ty) -> + expr_binop mem op ty + e1 (Cil.typeOf e1) + e2 (Cil.typeOf e2) + | UnOp (op, e1, ty) -> + expr_unop mem op ty e1 (Cil.typeOf e1) + + | Lval lval -> + let t = Cil.typeOf e in + let l = addr mem lval in + M.load mem (Ctypes.object_of t) l + + | StartOf lval -> + let ty_elt = + Ctypes.object_of_pointed (Ctypes.object_of (Cil.typeOf e)) in + M.V_pointer(ty_elt,startof mem ty_elt lval) + + | AddrOf lval -> + let ty_elt = + Ctypes.object_of_pointed (Ctypes.object_of (Cil.typeOf e)) + in + M.V_pointer(ty_elt,addr mem lval) + + | AlignOfE _ | AlignOf _ + | SizeOfE _ | SizeOf _ | SizeOfStr _ -> + let e' = Cil.constFold true e in + match e'.enode with + | Const _ -> expr mem e' + | _ -> + WpLog.not_yet_implemented "sizeof(%a)" + !Ast_printer.d_exp e + + + ( ----------------------------------------------------------------------- ) + ( --- Conditional Expression --- ) + ( ----------------------------------------------------------------------- ) + + let cond mem e = + match (Cil.stripInfo e).enode with + + | BinOp (op, e1, e2, ty) -> + cond_binop mem op ty e1 (Cil.typeOf e1) e2 (Cil.typeOf e2) + | UnOp (op, e1, ty) -> + cond_unop mem op ty e1 (Cil.typeOf e1) + + | _ -> boolean_of_value (expr mem e) + + + + + ( ----------------------------------------------------------------------- ) + ( --- Predicative translation of Conditional --- ) + ( ----------------------------------------------------------------------- ) + + let prop mem e = + match (Cil.stripInfo e).enode with + | Info _ -> WpLog.fatal "non translation for info type expression" + | Const (cnst) -> prop_const mem cnst + | CastE (ty,e) -> + if Cil.isPointerType ty && Cil.isZero e then + F.p_false + else + prop_cast (Cil.typeOf e) ty (expr mem e) + + | BinOp (op, e1, e2, ty) -> + prop_binop mem op ty + e1 (Cil.typeOf e1) + e2 (Cil.typeOf e2) + | UnOp (op, e1, ty) -> + prop_unop mem op ty e1 (Cil.typeOf e1) + + | Lval lval -> + let t = Cil.typeOf e in + let l = addr mem lval in + prop_of_value (M.load mem (Ctypes.object_of t) l) + + | StartOf lval -> + let ty_elt = + Ctypes.object_of_pointed (Ctypes.object_of (Cil.typeOf e)) + in + prop_of_loc (startof mem ty_elt lval) + + | AddrOf lval -> + prop_of_loc (addr mem lval) + + | AlignOfE _ | AlignOf _ + | SizeOfE _ | SizeOf _ | SizeOfStr _ -> + let e' = Cil.constFold true e in + match e'.enode with + | Const c -> prop_const mem c + | _ -> WpLog.not_yet_implemented "sizeof(%a)" + !Ast_printer.d_exp e + + ( ----------------------------------------------------------------------- ) + ( --- Recursion Bindings --- ) + ( ----------------------------------------------------------------------- ) + + let () = + begin + expr_rec := expr ; + cond_rec := cond ; + prop_rec := prop; + end + +end + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/translate_expr.mli frama-c-20111001+nitrogen+dfsg/src/wp/translate_expr.mli --- frama-c-20110201+carbon+dfsg/src/wp/translate_expr.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/translate_expr.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,62 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- *) +(** Translation of Expressions ) +( -------------------------------------------------------------------------- ) + +open Formula + +module Create (M : Mvalues.S): +sig + + + ( [addr mem lv] interprets the left value [lv] as + an address (memory location) in the memory [mem].) + val addr : M.mem -> Cil_types.lval -> M.loc + + + ( [expr mem e] interprets the expression[e] as a value + in memory [mem] ) + val expr : M.mem -> Cil_types.exp -> M.value + + ( [cond mem e] interprets [e] as a boolean + in memory [mem]. ) + val cond : M.mem -> Cil_types.exp -> M.F.boolean + + ( [prop mem e] interprets the expression[e] as a predicate + in memory [mem] ) + val prop : M.mem -> Cil_types.exp -> M.F.pred + + ([expr_cast mem ty_to ty_from e] casts [e] of type [ty_from] to type + type [ty_to] in memory [mem] ) + + val expr_cast : Cil_types.typ -> Cil_types.typ -> M.value -> M.value + +end + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/translate_prop.ml frama-c-20111001+nitrogen+dfsg/src/wp/translate_prop.ml --- frama-c-20110201+carbon+dfsg/src/wp/translate_prop.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/translate_prop.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,2217 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ ) +( --- Translation of Term and Predicats --- ) +( ------------------------------------------------------------------------ ) + +module WpLog = Wp_parameters + +open Ctypes +open Clabels +open Formula +open Cil_types +open Cil_datatype + +let debug = WpLog.debug ~dkey:"trans" + +module Create + (M : Mlogic.S) + = + +struct + + module F = M.F + module L = M.L + + ( ----------------------------------------------------------------------- ) + ( --- Registration of User-defined Predicate and Functions --- ) + ( ----------------------------------------------------------------------- ) + + type user_formal = + | UF_logic of logic_var F.var + | UF_references of + logic_var * F.var option * ( F.var * M.formal * string ) list + (lv, associated C var, list of formals at each label ) + | UF_closure of F.var * M.closure * string + (* a model variable (closure) required at a given label ) + + type userdef = { + d_info : logic_info ; + d_callname : string ; + d_formals : user_formal list ; + } + + type axiomlabel = { + a_name : string ; + a_defname : string ; + a_property : F.pred ; + a_memory : user_formal list ; + } + + module Hdef = Logic_var.Hashtbl + + ( Memoization of axioms compilation tables ) + let user_axioms : (string,F.pred option) Hashtbl.t = Hashtbl.create 131 + let user_axiomlabels : (string,axiomlabel option) Hashtbl.t = + Hashtbl.create 131 + let user_definitions = Hdef.create 131 + + let () = F.on_clear + (fun () -> + Hashtbl.clear user_axioms ; + Hashtbl.clear user_axiomlabels ; + Hdef.clear user_definitions ; + ) + + let rec pp_closures fmt (xs,cs) = + match xs , cs with + | [] , [] -> () + | x::xs , (c,l)::cs -> + Format.fprintf fmt "{%s:%a=%a@@%s}@," + (F.name_of_var x) + M.pp_tau (F.tau_of_var x) + M.pp_closure c l ; + pp_closures fmt (xs,cs) + | x::xs , [] -> + Format.fprintf fmt "{%s:%a=?}@," + (F.name_of_var x) + M.pp_tau (F.tau_of_var x) ; + pp_closures fmt (xs,[]) + | [] , (c,l)::cs -> + Format.fprintf fmt "{?=%a@@%s}@," + M.pp_closure c l ; + pp_closures fmt ([],cs) + + let pp_formals fmt xs = + List.iter + (fun x -> + Format.fprintf fmt "(%s:%a)@," + (F.name_of_var x) + M.pp_tau (F.tau_of_var x) ; + ) xs + + module UserDefinition = + struct + let lock : unit Hdef.t = Hdef.create 131 + let () = F.on_clear (fun () -> Hdef.clear lock) + + let pp_userdef_title fmt d = + let f = d.d_info in + let x = f.l_var_info.lv_name in + match f.l_type with + | Some _ -> + if f.l_tparams=[] && f.l_labels=[] + then Format.fprintf fmt "User-defined constant %s" x + else Format.fprintf fmt "User-defined function %s" x + | None -> + Format.fprintf fmt "User-defined predicate %s" x + + let pp_userformals fmt ufs = + List.iter + (function + | UF_logic(lv,x) -> + Format.fprintf fmt + "@\n (%a:%a) parameter '%s' in ACSL definition" + F.pp_var x F.pp_tau (F.tau_of_var x) + (* original name of lv ) lv.lv_name + | UF_references(lv,opt_cx,refs) -> + begin + match opt_cx with + | None -> () + | Some y -> + Format.fprintf fmt "@\n (%a:%a) C reference to %a" + F.pp_var y F.pp_tau (F.tau_of_var y) + !Ast_printer.d_logic_var lv + end; + List.iter + (fun (x,formal,label) -> + Format.fprintf fmt "@\n * (%a:%a) reference to %a at %s" + F.pp_var x F.pp_tau (F.tau_of_var x) + M.pp_formal (formal,lv) label ) + refs + | UF_closure(x,closure,label) -> + Format.fprintf fmt "@\n * (%a:%a) %a at %s" + F.pp_var x F.pp_tau (F.tau_of_var x) + M.pp_closure closure label + ) ufs + + let pp_userdef_descr fmt d = + if d.d_formals <> [] then + begin + Format.fprintf fmt "Signature:" ; + pp_userformals fmt d.d_formals ; + end + + let define duser items = + let k = duser.d_info.l_var_info in + List.iter + (fun (name,item) -> + let section = + match item with + | Function _ | Predicate _ -> S_User_Sig + | Axiom _ -> S_User_Prop + | _ -> assert false + in + F.add_declaration { + d_name = name ; + d_section = section ; + d_title = (fun fmt -> pp_userdef_title fmt duser) ; + d_descr = (fun fmt -> pp_userdef_descr fmt duser) ; + d_source = None ; + d_item = item ; + }) + items ; + Hdef.remove lock k + + let unlock xdef = + Hdef.remove lock xdef + + let lock xdef = + if Hdef.mem lock xdef then + ( Wp_parameters.not_yet_implemented "Recursive definition (in '%a')" + !Ast_printer.d_logic_var xdef ) ; + Hdef.add lock xdef () + + end + + module UserAxiom = F.DRegister + (struct + type t = string + module H = Hashtbl.Make + (struct + type t = string + let hash = Hashtbl.hash + let equal: string -> string -> bool = (=) + end) + let section = S_User_Prop + let source = None + let prefix = "Hyp" + let clear () = () + let index x = x + let basename x = x + let location _x = None + let declare x _ = + try + match Hashtbl.find user_axioms x with + | Some p -> Formula.Axiom p + | None -> raise Not_found + with Not_found -> Wp_parameters.fatal "Uncompiled axiom (%s)" x + let pp_title fmt x = Format.fprintf fmt "User-defined axiom %s" x + let pp_descr fmt _x = Format.fprintf fmt "No labels." + end) + + module UserAxiomDefs = + struct + + let pp_labels fmt = function + | [] -> () + | x::xs -> + Format.fprintf fmt "@[{%s" x ; + List.iter (fun x -> Format.fprintf fmt ",%s" x) xs ; + Format.fprintf fmt "}@]" + + let pp_axiomdef_title fmt a = + Format.fprintf fmt "User defined axiom %s" a.a_name + + let pp_axiomdef_descr fmt a = + if a.a_memory <> [] then + begin + Format.fprintf fmt "Memory parameters: " ; + UserDefinition.pp_userformals fmt a.a_memory ; + end + + let define axdef = + F.add_declaration { + d_name = axdef.a_defname ; + d_section = S_User_Prop ; + d_title = (fun fmt -> pp_axiomdef_title fmt axdef) ; + d_descr = (fun fmt -> pp_axiomdef_descr fmt axdef) ; + d_source = None ; + d_item = Formula.Axiom axdef.a_property ; + } + + let is_defined name = F.has_declaration ("Hyp_" ^ name) + + end + + (* ----------------------------------------------------------------------- ) + ( --- Frame Environment --- ) + ( ----------------------------------------------------------------------- ) + + module Lmap = Map.Make + (struct + type t = c_label + let compare = Pervasives.compare + end) + + type frame = { + mutable states : M.mem Lmap.t ; + mutable result : F.var option ; + mutable status : F.var option ; + mutable return : Cil_types.typ option ; + } + + let new_frame kf ?m_here ?m_pre ?m_post ?x_result ?x_status () = + let bind l x s = match x with None -> s | Some m -> Lmap.add l m s in + let states = + bind Clabels.Here m_here + (bind Clabels.Pre m_pre + (bind Clabels.Post m_post + Lmap.empty)) + in { + states = states ; + result = x_result ; + status = x_status ; + return = Some(Kernel_function.get_return_type kf) ; + } + + let user_frame () = + { + states = Lmap.empty ; + result = None ; + status = None ; + return = None ; + } + + let result frame = + match frame.result with + | Some x -> x + | None -> + match frame.return with + | Some typ -> + let tau = M.tau_of_logic_type (Ctype typ) in + let x = L.fresh "result" (Formula.Acsl(tau,Ctype typ)) in + frame.result <- Some x ; x + | None -> + Wp_parameters.fatal "Result type undefined" + + let status frame = + match frame.status with + | Some x -> x + | None -> + let x = L.fresh "status" (Formula.Model Formula.Integer) in + frame.status <- Some x ; x + + ( ----------------------------------------------------------------------- ) + ( --- Translation Environment --- ) + ( ----------------------------------------------------------------------- ) + + type lvar_kind = ( What represents a given logic_var (lv) ) + | Logic_cvar of varinfo ( (lv) is a varinfo ) + | Logic_value of M.value ( (lv) mapsto a value in the model ) + | Logic_term of F.abstract ( (lv) mapsto an arbitrary ACSL value ) + | Logic_var of F.var ( (lv) mapsto a collectable FOL variable ) + | Logic_byref ( (lv) is a formal parameter of logic passed by reference ) + + type env = { + formals_in_pre : bool ; + frame : frame ; + label : c_label ; + xvars : M.value Varinfo.Map.t ; + ( maping of logic_vars when lv_origin<>None ) + lvars : lvar_kind Logic_var.Map.t ; + ( lvar_kind of logic_vars when lv_origin=None ) + mutable laddr : F.var Logic_var.Map.t ; + ( addresses of by-reference user formal ) + } + + + + let fresh_addr lv : F.var = + debug "[fresh_addr] of %a" !Ast_printer.d_logic_var lv; + let tau = Formula.Pointer (M.tau_of_loc) in + let x = L.fresh lv.lv_name (Formula.Model tau) in + debug "[fresh_addr] of %a : %a" !Ast_printer.d_logic_var lv F.pp_var x; + x + + let addr_of_ref env lv = + debug "[addr_of_ref] of %a" !Ast_printer.d_logic_var lv; + try + let x = Logic_var.Map.find lv env.laddr in + debug "[addr_of_ref] of %a already recorded :%a" + !Ast_printer.d_logic_var lv F.pp_var x ; x + with + Not_found -> + debug "[addr_of_ref] %a not yet in" + !Ast_printer.d_logic_var lv; + let x = fresh_addr lv in + env.laddr <-Logic_var.Map.add lv x env.laddr ; + debug "[addr_of_ref] of %a recorded with %a" + !Ast_printer.d_logic_var lv F.pp_var x ; x + + + +( -------------------------------------------------------------------------- ) +( --- Global Recursion for Logic Functions (for logic constants) --- ) +( -------------------------------------------------------------------------- ) + + let rec_apply_function + : (env -> logic_info -> + (logic_label logic_label) list -> + term list -> F.abstract) ref + = ref (fun _ _ _ _ -> assert false) + +(* -------------------------------------------------------------------------- ) +( --- Logic-Variable access --- ) +( -------------------------------------------------------------------------- ) + + let lvar env lv : lvar_kind = + match lv.lv_origin with + | None -> + begin + try Logic_var.Map.find lv env.lvars + with Not_found -> + try + let cst = Logic_env.find_logic_cons lv in + Logic_term (!rec_apply_function env cst [] []) + with Not_found -> + Wp_parameters.abort "Unknown logic constant %s" lv.lv_name + end + | Some vi -> + begin + try Logic_value (Varinfo.Map.find vi env.xvars) + with Not_found -> Logic_cvar vi + end + + let xvar env vi : M.value option = + try Some(Varinfo.Map.find vi env.xvars) with Not_found -> None + +( -------------------------------------------------------------------------- ) +( --- Allocation of (collectable) logic variables --- ) +( -------------------------------------------------------------------------- ) + + let fresh_local lv : F.var = + let lt = lv.lv_type in + let tau = M.tau_of_logic_type lt in + L.fresh lv.lv_name (Formula.Acsl(tau,lt)) + + let fresh_logic_var pool lv = + let lt = lv.lv_type in + let t = M.tau_of_logic_type lt in + F.p_fresh pool lv.lv_name (Formula.Acsl(t,lt)) + + let add_logic_vars env pool lvs = + let lvars = + List.fold_left + (fun lvars lv -> + let x = fresh_logic_var pool lv in + Logic_var.Map.add lv (Logic_var x) lvars) + env.lvars lvs + in { env with lvars = lvars } + + let collect_logic_vars env = + Logic_var.Map.fold + (fun _lv lk acc -> + match lk with + | Logic_var x -> x::acc + | _ -> acc) + env.lvars [] + + ( -------------------------------------------------------------------------- ) + ( --- Local Bindings of logic variables to values --- ) + ( -------------------------------------------------------------------------- ) + + let bind_lvars env (bindings : (logic_var F.abstract) list) = + let lvars = + List.fold_left + (fun lvars (lv,term) -> Logic_var.Map.add lv (Logic_term term) lvars) + env.lvars bindings + in { env with lvars = lvars } + + let bind_lvar env lv term = + { env with lvars = Logic_var.Map.add lv (Logic_term term) env.lvars } + + let bind_fresh env lv : (F.var * env) = + let x = fresh_local lv in + x , bind_lvar env lv (F.var x) + +(* -------------------------------------------------------------------------- ) +( --- Access to memory label in environment --- ) +( -------------------------------------------------------------------------- ) + + let env_at e label = { + formals_in_pre = e.formals_in_pre ; + frame = e.frame ; + label = label ; + lvars = e.lvars ; + xvars = e.xvars ; + laddr = e.laddr; + } + + let find_mem env label = + try Some (Lmap.find label env.frame.states) + with Not_found -> None + + let mem_at env label = + try Lmap.find label env.frame.states + with Not_found -> + let m = M.mem () in + env.frame.states <- Lmap.add label m env.frame.states ; m + + let mem_at_env env = mem_at env env.label + +( -------------------------------------------------------------------------- ) +( --- Return & Exit-Status variables --- ) +( -------------------------------------------------------------------------- ) + + let subst_result env vopt p = + if env.frame.result = None then p + else + let x = result env.frame in + match vopt with + | None -> L.forall [x] p + | Some v -> L.subst x (M.logic_of_value v) p + + let result_type env = + match env.frame.return with + | None -> Wp_parameters.fatal "no result type" + | Some t -> t + + let exit_status env = status env.frame + +( -------------------------------------------------------------------------- ) +( --- Environment Constructors --- ) +( -------------------------------------------------------------------------- ) + + let env kf ?m_here ?m_pre ?m_post ?x_result () = + { + formals_in_pre = false ; + frame = new_frame kf ?m_here ?m_pre ?m_post ?x_result () ; + label = Here ; + lvars = Logic_var.Map.empty ; + xvars = Varinfo.Map.empty ; + laddr = Logic_var.Map.empty; + } + +( -------------------------------------------------------------------------- ) +( --- Environment Constructors for Calling Functions --- ) +( -------------------------------------------------------------------------- ) + + ( Associates formal parameters to values ) + let bind_formals called_kf vs = + let rec bind xvars xs vs = + match xs , vs with + | x::xs , v::vs -> bind (Varinfo.Map.add x v xvars) xs vs + | _ -> xvars + in ( prototypes have exactly the good number of variables ) + bind Varinfo.Map.empty (Kernel_function.get_formals called_kf) vs + + let call_pre caller_env called_kf vs m_pre = + let frame = new_frame called_kf ~m_here:m_pre ~m_pre:m_pre () in + { + formals_in_pre = false ; + frame = frame ; + label = Here ; + lvars = caller_env.lvars ; + xvars = bind_formals called_kf vs ; + laddr = caller_env.laddr ; + } + + let call_post caller_env called_kf vs m_pre m_post x_result = + let frame = + new_frame called_kf ~m_here:m_post ~m_pre ~m_post ?x_result () + in + { + formals_in_pre = true ; + frame = frame ; + label = Here ; + lvars = caller_env.lvars ; + xvars = bind_formals called_kf vs ; + laddr = caller_env.laddr + } + + let call_exit caller_env called_kf vs m_pre m_post x_status = + let frame = + new_frame called_kf ~m_here:m_post ~m_pre ~m_post ~x_status () + in + { + formals_in_pre = false ; + frame = frame ; + label = Here ; + lvars = caller_env.lvars ; + xvars = bind_formals called_kf vs ; + laddr = caller_env.laddr ; + } + + ( ----------------------------------------------------------------------- ) + ( --- Translation Values --- ) + ( ----------------------------------------------------------------------- ) + + ( kinds are logic types ) + type kind = + | Kcint of Ctypes.c_int + | Kint + | Kreal + | Kbool + | Kptr of Cil_types.typ + | Kset of kind + | Kstruct of compinfo + | Karray of arrayinfo + | Kadt of string kind list + + + let rec kind_equal ka kb = + match ka,kb with + | Kcint i, Kcint j -> i = j + | Kint, Kint | Kreal, Kreal | Kbool, Kbool -> true + | Kptr t, Kptr t' -> Typ.equal t t' + | Kset k, Kset k' -> kind_equal k k' + | Kstruct cp, Kstruct cp' -> Compinfo.equal cp cp' + | Karray a, Karray a' -> AinfoComparable.equal a a' + | Kadt (s,ks), Kadt(s',ks') -> + s=s' && List.for_all2 kind_equal ks ks' + | _, _ -> false + + let pp_kind fmt = function + | Kcint i -> Ctypes.pp_int fmt i + | Kint -> Format.pp_print_string fmt "int" + | Kreal -> Format.pp_print_string fmt "real" + | Kptr _-> Format.pp_print_string fmt "pointer" + | Kset _-> Format.pp_print_string fmt "set" + | Kstruct c -> Format.pp_print_string fmt c.cname + | Karray a -> Ctypes.pretty fmt (C_array a) + | Kadt (s,_) -> Format.pp_print_string fmt s + | Kbool -> Format.pp_print_string fmt "bool" + + type data = + | Data of F.abstract (* Singleton ) + | Loc of M.loc + | Value of M.value + | Interval of F.interval + | Range of c_object M.loc * F.interval + | List of data list + | Set of F.set + + let pp_data fmt = function + | Data d -> Format.fprintf fmt "Data=%a" F.pp_term d + | Loc l -> Format.fprintf fmt "Loc=%a" M.pp_loc l + | Value v -> Format.fprintf fmt "Value=%a" M.pp_value v + | _ -> Format.fprintf fmt "Blob" + + let data_of_integer (x : F.integer) : data = Data (F.wrap x) + let data_of_real (x : F.real) : data = Data(F.wrap x) + let data_of_boolean (x:F.boolean) : data = Data (F.wrap x) + + let integer_of_value = function + | M.V_int(_,t) -> t + | v -> Wp_parameters.fatal "integer_of_value %a" M.pp_value v + + let real_of_value = function + | M.V_float(_,t) -> t + | M.V_int(_,t) -> F.real_of_integer t + | v -> WpLog.fatal "[real_of_value] of %a" M.pp_value v + + let extract_from_data = function + | Data d -> F.unwrap d + | Value v -> F.unwrap (M.logic_of_value v) + | d -> WpLog.fatal "[extract_from_data] of %a" pp_data d + + let boolean_of_data d : F.boolean = extract_from_data d + let array_of_data d : F.array = extract_from_data d + let record_of_data d : F.record = extract_from_data d + let urecord_of_data d : F.urecord = extract_from_data d + + let loc_of_data obj d = + match d with + | Value(M.V_pointer(_,l)) -> l + | Value v -> M.loc_of_term obj (F.unwrap (M.logic_of_value v)) + | Data l -> M.loc_of_term obj (F.unwrap l) + | Loc l -> l + | _ -> + Wp_parameters.fatal ~current:true "not a loc (%a)" pp_data d + + let integer_of_data k d : F.integer = + match d with + | Data d -> + begin + match k with + | Kint | Kcint _ -> F.unwrap d + | k -> WpLog.fatal ~current:true "not an integer (%a : %a)" + F.pp_term d pp_kind k + end + | Value v -> integer_of_value v + | _ -> WpLog.fatal ~current:true "not an integer (%a)" pp_data d + + let real_of_data k d = + match k with + | Kint | Kcint _-> F.real_of_integer (integer_of_data k d) + | Kreal -> + begin + match d with + | Data d -> F.unwrap d + | Value v -> real_of_value v + | _ -> WpLog.fatal ~current:true "not a real (%a)" pp_data d + end + | _ -> WpLog.fatal ~current:true "not a real (%a)" pp_data d + + + let rec set_of = function + | Value v -> F.singleton (M.logic_of_value v) + | Data d -> F.singleton d + | Loc l -> F.singleton (M.term_of_loc l) + | List ds -> F.unions (List.map set_of ds) + | Interval i -> F.interval i + | Set s -> s + | Range _ -> Wp_parameters.not_yet_implemented "set of zone" + + let list_of = function + | (Value _|Data _|Loc _|Interval _|Range _) as d -> [d] + | List xs -> xs + | Set _ -> WpLog.fatal "[list_of] a set" + + let union_data a b = + match a,b with + | Set a , b | b, Set a -> Set (F.union a (set_of b)) + | List _ , _ | _ , List _ -> List (list_of a @ list_of b) + | ( (Value _|Data _|Loc _|Range _|Interval _ ) , + (Value _|Data _|Loc _|Range _|Interval _ ) ) -> List[a;b] + + let union_map f = function + | [] -> List [] + | d::ds -> + List.fold_left + (fun w x -> union_data w (f x)) + (f d) ds + + let term_of_data = function + | Data t -> t + | Value v -> M.logic_of_value v + | Loc l -> F.wrap (M.term_of_loc l) + | Set s -> F.wrap s + | List dl -> F.wrap (F.unions (List.map (set_of) dl)) + | Range _ -> Wp_parameters.not_yet_implemented "set of zone" + | Interval i -> F.wrap (F.interval i ) + + let neg_interval r = + match r.F.inf,r.F.sup with + | Some j, None -> {F.inf = None ; F.sup = Some (F.e_ineg j)} + | None , Some j -> {F.inf = Some (F.e_ineg j) ; F.sup = None} + | Some j, Some k -> + {F.inf = Some (F.e_ineg k) ; F.sup = Some (F.e_ineg j)} + | None, None -> r + + (* ----------------------------------------------------------------------- ) + ( --- Logic Types --- ) + ( ----------------------------------------------------------------------- ) + + let rec object_of_pointed = function + | Kptr te | Kset(Kptr te) -> Ctypes.object_of te + | _ -> WpLog.fatal "Dereferencing a non-pointer value" + + let kind_of_typ c= + match object_of c with + | C_int i -> Kcint i + | C_float _ -> Kreal + | C_pointer te -> Kptr te + | C_comp comp -> Kstruct comp + | C_array arr -> Karray arr + + let kind_of_data ty = function + | (Data _ | Loc _ | Value _) -> kind_of_typ ty + | (Interval _ | Range _ | List _ | Set _) -> Kset (kind_of_typ ty) + + let rec kind_of = function + | Ctype c -> kind_of_typ c + | Linteger -> Kint + | Lreal -> Kreal + | Ltype ({lt_name="𝔹"}, _) -> Kbool + | Ltype( {lt_name="set"} , [elt] ) -> Kset(kind_of elt) + | Ltype( {lt_name=adt} , args ) -> Kadt(adt,List.map kind_of args) + | Lvar _ -> WpLog.not_yet_implemented "logic type variables" + | Larrow _ -> WpLog.not_yet_implemented "type of logic function" + + let typ_of_elements = function + | Ctype c -> + let o = object_of c in + begin + match o with + | C_pointer te -> te + | C_array arr -> arr.arr_element + | _ -> + WpLog.fatal "elements of non-pointer type %a" Ctypes.pp_object o + end + | t -> WpLog.fatal "elements of non-pointer type: %a" + !Ast_printer.d_logic_type t + + ( ----------------------------------------------------------------------- ) + ( --- Global Recursions --- ) + ( ----------------------------------------------------------------------- ) + + let data_rec : (env -> term -> data) ref = ref (fun _ _ -> assert false) + + ( ---------------------------------------------------------------------- ) + ( --- Data memory predicate --- ) + ( ---------------------------------------------------------------------- ) + + let rec assigned_of_data te acc d = + match d with + | (Data _|Value _|Loc _) -> + F.Aloc(te,loc_of_data te d)::acc + | Range(te,loc,range) -> + F.Arange(te,loc,range)::acc + | List ds -> List.fold_left (assigned_of_data te) acc ds + | _ -> Wp_parameters.not_yet_implemented "arbitrary zone" + + let data_valid m k d = + let t = + match k with + | Kptr te -> te + | Kset (Kptr te) -> te + | _ -> WpLog.fatal "unexpected type for valid predicate" + in + let te = Ctypes.object_of t in + F.p_conj (List.map (M.valid m) (assigned_of_data te [] d)) + + let data_separated m (t1, d1) (t2, d2) = + let r1 = assigned_of_data t1 [] d1 in + let r2 = assigned_of_data t2 [] d2 in + let p = ref F.p_true in + List.iter + (fun a -> + List.iter + (fun b -> + p := F.p_and !p (M.separated m a b) + ) r2 + ) r1 ; + !p + + ( ---------------------------------------------------------------------- ) + ( --- Data memory operation --- ) + ( ---------------------------------------------------------------------- ) + + let rec data_shift_range tobj loc kbi dindex ~is_pos = + match dindex with + | Data _ | Value _ | Loc _ as d -> + let idx =integer_of_data kbi d in + let idx = if is_pos then idx else F.e_ineg idx in + Loc (M.shift loc tobj idx) + | List il -> union_map (data_shift_range tobj loc kbi ~is_pos) il + | Interval r -> + let r = if is_pos then r else neg_interval r in Range(tobj,loc,r) + | Set _ | Range _ -> + Wp_parameters.not_yet_implemented "pointer shift over arbitrary sets" + + let rec data_index_range tobj loc kbi dindex = + match dindex with + | Data _ | Value _ | Loc _ as d -> + Loc (M.index loc tobj (integer_of_data kbi d)) + | List il -> union_map (data_index_range tobj loc kbi ) il + | Interval r -> Range(tobj,loc,r) + | Set _ | Range _ -> + Wp_parameters.not_yet_implemented "array access over arbitrary sets" + + + let data_shift ka ga kb gb ~is_pos = + match ka,kb with + | (Karray _ | Kptr _ ) , (Kint | Kcint _) -> + let obj = object_of_pointed ka in + let gb = integer_of_data kb gb in + let gb = if is_pos then gb else (F.e_ineg gb) in + Loc (M.shift + (loc_of_data obj ga) + obj gb) + | (Kptr _ | Karray _) , (Kset ((Kint | Kcint _) as kbi)) -> + let obj = object_of_pointed ka in + data_shift_range obj (loc_of_data obj ga) kbi gb ~is_pos + | _ -> WpLog.not_yet_implemented "shift over arbitrary sets of pointers" + + let data_index ta ka ga kb gb = + match ka,kb with + | (Karray _ | Kptr _) , (Kint | Kcint _) -> + Loc (M.index (loc_of_data ta ga) ta (integer_of_data kb gb)) + | (Karray _ | Kptr _) , (Kset ((Kint |Kcint _) as kbi)) -> + data_index_range ta (loc_of_data ta ga) kbi gb + | _ -> WpLog.not_yet_implemented "shift over arbitrary sets of pointers" + + let data_field ka ga f = + match ka with + | Kset _ -> Wp_parameters.not_yet_implemented "field access over sets" + | _ -> let obj = object_of f.ftype in Loc (M.field (loc_of_data obj ga) f) + + let rec data_startof_set ta ga = + match ga with + | Value _ | Data _ | Loc _ -> + Loc (M.startof (loc_of_data ta ga) ta) + | Set _ | Range _ -> + Wp_parameters.not_yet_implemented "start-of over sets" + | List pl -> + union_map (fun p -> data_startof_set ta p ) pl + | Interval _ -> WpLog.fatal "unexpected argument for [startof]" + + let data_startof ta ka ga = + match ka with + | Kset _ -> data_startof_set ta ga + | _ -> Loc( M.startof (loc_of_data ta ga) ta ) + + let rec data_load env ty = function + | Loc _ | Data _ | Value _ as d -> + let obj = object_of ty in + Value (M.load (mem_at_env env) obj (loc_of_data obj d)) + | Range _ -> + Wp_parameters.not_yet_implemented "load of arbitrary region" + | Set _ -> + Wp_parameters.not_yet_implemented "load of arbitrary sets" + | List pl -> union_map (data_load env ty) pl + | _ -> WpLog.fatal "unexpected argument for [load]" + + + ( ---------------------------------------------------------------------- ) + ( --- Offsets inside functional memory model --- ) + ( ---------------------------------------------------------------------- ) + + let rec logic_offset env a = function + | TNoOffset -> Data a + | TField(f,off) -> + let fieldvalue = F.acc_field (F.unwrap a) f in + logic_offset env fieldvalue off + | TIndex (t,off) -> + let i = integer_of_data (kind_of t.term_type) (!data_rec env t) in + logic_offset env (F.acc_index (F.unwrap a) i) off + + let rec loc_offset env loc ty = function + | TNoOffset -> loc + | TField(f,off) -> + loc_offset env (M.field loc f) (Ctypes.object_of f.ftype) off + | TIndex(t,off) -> + let k = integer_of_data (kind_of t.term_type) (!data_rec env t) in + let te = Ctypes.object_of_array_elem ty in + loc_offset env (M.index loc te k) te off + + ( ---------------------------------------------------------------------- ) + ( --- Offsets in the C-memory model --- ) + ( ---------------------------------------------------------------------- ) + + let rec memory_offset env ty (dp:data) = function + | TNoOffset -> ty,dp + | TIndex(t,off) -> + let kp = kind_of_data ty dp in + let ki = kind_of t.term_type in + let di = !data_rec env t in + let te = Cil.typeOf_array_elem ty in + let ta = object_of te in + let dq = data_index ta kp dp ki di in + memory_offset env te dq off + | TField(f,off) as offset -> + (match dp with + | Range _ | Set _ | List _ -> + Datalib.Collector.add_warning + ~reason:"field access over set of l-values" + "Ignored offset '%a' in assign clause" + !Ast_printer.d_term_offset offset ; + ty, dp + | dp -> + let dq = data_field (kind_of_typ ty) dp f in + memory_offset env f.ftype dq off ) + + let gaddress_of_cvar tenv x off : (typ data) = + let tenv = + if tenv.formals_in_pre && x.vformal + then (env_at tenv Pre) else tenv + in + memory_offset tenv x.vtype (Loc (M.cvar (mem_at_env tenv) x)) off + + + let gaddress_of_ref tenv lv off : data = + let loc = M.lvar (mem_at_env tenv) lv (addr_of_ref tenv lv) in + match lv.lv_type with + | Ctype ty -> + let tr,gloc = memory_offset tenv ty (Loc loc) off in + data_load tenv tr gloc + | ty -> + begin + match off with + | TNoOffset -> Loc loc + | _ -> + let s = "[gaddress_of_ref] C offset of logic_var" in + WpLog.fatal "%s %a with a pure logic type %a" + s !Ast_printer.d_logic_var lv + !Ast_printer.d_logic_type ty + end + + + + + let gaddress_of_mem tenv e off : (typ * data) = + let g = !data_rec tenv e in + let te = + match kind_of e.term_type with + | Kptr telt -> telt + | Kset(Kptr telt) -> telt + | _ -> WpLog.fatal "expected pointer" + in + memory_offset tenv te g off + + let gstartof (ty,g) = + let te = Cil.typeOf_array_elem ty in + let ta = object_of te in + data_startof ta (kind_of_typ ty) g + + let gstartof_cvar env x off = + gstartof (gaddress_of_cvar env x off) + + let gstartof_mem env e off = + gstartof (gaddress_of_mem env e off) + + let gstartof_value env ty v off = + gstartof (memory_offset env ty (Value v) off) + + (* ---------------------------------------------------------------------- ) + ( --- Arithmetics Cast --- ) + ( ---------------------------------------------------------------------- ) + + let cast v ty_from ty_to = + if kind_equal ty_from ty_to then v + else + match ty_from with + | Kcint i -> + let vi = integer_of_data ty_from v in + begin match ty_to with + | Kcint j -> + if Ctypes.sub_c_int i j then v + else + Value (M.V_int(j,F.modulo j vi)) + | Kint -> Data(F.wrap vi) + | Kreal -> Data(F.wrap (F.real_of_integer vi)) + | Kptr te -> Loc (M.cast_int_to_loc i vi te) + | k -> WpLog.not_yet_implemented "logic cast from %a to %a" + Ctypes.pp_int i pp_kind k + end + | Kint -> + let vi = integer_of_data ty_from v in + begin match ty_to with + | Kcint j -> Value (M.V_int(j,F.modulo j vi)) + | Kint -> Data(F.wrap vi) + | Kptr te -> Loc (M.cast_int_to_loc (Ctypes.c_ptr()) vi te) + | Kreal -> Data(F.wrap (F.real_of_integer vi)) + | k -> WpLog.not_yet_implemented + "logic cast from integer to %a" pp_kind k + end + | Kreal -> + let vr = real_of_data ty_from v in + begin match ty_to with + | Kcint j -> Value(M.V_int(j,F.modulo j + (F.integer_of_real vr))) + | Kint -> Data(F.wrap (F.integer_of_real vr)) + | Kreal -> Data(F.wrap vr) + | k -> WpLog.not_yet_implemented + "logic cast from real to %a" pp_kind k + end + | Kptr tfrom -> + let loc = loc_of_data (object_of tfrom) v in + begin match ty_to with + | Kcint j -> Value (M.V_int(j, M.cast_loc_to_int tfrom loc j)) + | Kptr tto -> Loc (M.cast_loc_to_loc tfrom tto loc) + | k -> WpLog.not_yet_implemented + "logic cast from pointer over %a to %a" + !Ast_printer.d_type tfrom pp_kind k + end + | k -> WpLog.not_yet_implemented "logic cast from %a to %a" + pp_kind k pp_kind ty_to + + + ( ---------------------------------------------------------------------- ) + ( --- Binary Operators --- ) + ( ---------------------------------------------------------------------- ) + + let int_op = function + | PlusA -> F.e_iop Formula.Iadd + | MinusA -> F.e_iop Formula.Isub + | Mult -> F.e_iop Formula.Imul + | Div -> F.e_iop Formula.Idiv + | Mod -> F.e_iop Formula.Imod + | BAnd -> F.e_band + | BXor -> F.e_bxor + | BOr -> F.e_bor + | Shiftlt -> F.e_lshift + | Shiftrt -> F.e_rshift + | _ -> WpLog.fatal "[int_op] non integer operator" + + let real_op = function + | PlusA -> F.e_rop Formula.Radd + | MinusA -> F.e_rop Formula.Rsub + | Mult -> F.e_rop Formula.Rmul + | Div -> F.e_rop Formula.Rdiv + | _ -> WpLog.fatal "[real_op] non real operator" + + let rel_op = function + | Rlt -> Lt + | Rgt -> Gt + | Rle -> Le + | Rge -> Ge + | Req -> Eq + | Rneq -> Ne + + let real_cmp op r1 r2 = + match op with + | Lt -> F.e_rcmp Formula.Clt r1 r2 + | Gt -> F.e_rcmp Formula.Clt r2 r1 + | Le -> F.e_rcmp Formula.Cleq r1 r2 + | Ge -> F.e_rcmp Formula.Cleq r2 r1 + | Eq -> F.e_rcmp Formula.Ceq r1 r2 + | Ne -> F.e_rcmp Formula.Cneq r1 r2 + | _ -> WpLog.fatal "[real_cmp] non real comparator" + + let int_cmp op i1 i2 = + match op with + | Lt -> F.e_icmp Formula.Clt i1 i2 + | Gt -> F.e_icmp Formula.Clt i2 i1 + | Le -> F.e_icmp Formula.Cleq i1 i2 + | Ge -> F.e_icmp Formula.Cleq i2 i1 + | Eq -> F.e_icmp Formula.Ceq i1 i2 + | Ne -> F.e_icmp Formula.Cneq i1 i2 + | _ -> WpLog.fatal "[int_cmp] non intger comparator" + + let preal_cmp op r1 r2 = + match op with + | Lt -> F.p_rcmp Formula.Clt r1 r2 + | Gt -> F.p_rcmp Formula.Clt r2 r1 + | Le -> F.p_rcmp Formula.Cleq r1 r2 + | Ge -> F.p_rcmp Formula.Cleq r2 r1 + | Eq -> F.p_rcmp Formula.Ceq r1 r2 + | Ne -> F.p_rcmp Formula.Cneq r1 r2 + | _ -> WpLog.fatal "[preal_cmp] non real relation" + + let pint_cmp op i1 i2 = + match op with + | Lt -> F.p_icmp Formula.Clt i1 i2 + | Gt -> F.p_icmp Formula.Clt i2 i1 + | Le -> F.p_icmp Formula.Cleq i1 i2 + | Ge -> F.p_icmp Formula.Cleq i2 i1 + | Eq -> F.p_icmp Formula.Ceq i1 i2 + | Ne -> F.p_icmp Formula.Cneq i1 i2 + | _ -> WpLog.fatal "[pint_cmp] non integer relation" + + let ptr_rel op l1 l2 = + match op with + | Lt -> M.lt_loc l1 l2 + | Gt -> M.lt_loc l2 l1 + | Le -> M.le_loc l1 l2 + | Ge -> M.le_loc l2 l1 + | Eq -> M.equal_loc l1 l2 + | Ne -> F.p_not (M.equal_loc l1 l2) + | _ -> WpLog.fatal "[ptr_rel] non pointer relation" + + let ptr_cmp op l1 l2 = + match op with + | Lt -> M.lt_loc_bool l1 l2 + | Gt -> M.lt_loc_bool l2 l1 + | Le -> M.le_loc_bool l1 l2 + | Ge -> M.le_loc_bool l2 l1 + | Eq -> M.equal_loc_bool l1 l2 + | Ne -> F.e_not (M.equal_loc_bool l1 l2) + | _ -> WpLog.fatal "[ptr_cmp] non pointer comparator" + + let plus i j = F.e_iop Formula.Iadd i j + + let plus_interval r i = + match r.F.inf , r.F.sup with + | None , None -> r + | Some j, None -> {F.inf = Some (plus i j ); F.sup = None} + | None, Some k -> {F.inf = None ; F.sup = Some (plus i k)} + | Some j, Some k -> {F.inf = Some (plus i j );F.sup = Some (plus i k)} + + let plus_interval_interval a b = + match a , b with + | ({ F.sup=None ; F.inf=None } as top) , _ + | _ , ({ F.sup=None ; F.inf=None } as top) -> Interval top + | _ -> Set (F.add_set (F.interval a) (F.interval b)) + + + let rec add_integer ka ga kb gb = + match ga,gb with + | Set _ , _ | _ , Set _ -> Set (F.add_set (set_of ga) (set_of gb)) + | (Value _ | Data _), (Value _ | Data _) -> + data_of_integer (plus (integer_of_data ka ga) (integer_of_data kb gb)) + | Interval r1 , Interval r2 ->plus_interval_interval r1 r2 + | (Value _ | Data _ ),Interval r -> + Interval (plus_interval r (integer_of_data ka ga)) + | Interval r,(Value _ | Data _ ) -> + Interval (plus_interval r (integer_of_data kb gb)) + | List _ , List _ -> Set (F.add_set (set_of ga) (set_of gb)) + | List ds , b -> union_map (add_integer kb b ka) ds + | b , List ds -> union_map (add_integer ka b kb) ds + | _ -> WpLog.fatal "unsuitable arguments for integer addition" + + let data_cmp binop ka ga kb gb = + match ka,kb with + |( Kint | Kcint _) , (Kint| Kcint _) -> + int_cmp binop (integer_of_data ka ga) (integer_of_data kb gb) + | (Kreal|Kint| Kcint _) , (Kreal|Kint| Kcint _) -> + real_cmp binop (real_of_data ka ga) (real_of_data kb gb) + | Kptr ty , Kptr _ -> + let obj = object_of ty in + ptr_cmp binop (loc_of_data obj ga) (loc_of_data obj gb) + | _ -> + Wp_error.not_yet_implemented + "boolean comparison between %a and %a" + pp_kind ka pp_kind kb + + let data_binop kr binop ka ga kb gb = + match binop with + + ( pointer arithmetics ) + + | (IndexPI | PlusPI) -> data_shift ka ga kb gb ~is_pos:true + | MinusPI -> data_shift ka ga kb gb ~is_pos:false + | MinusPP -> + begin + match ka with + | Kptr te -> + let obj = object_of te in + data_of_integer + (M.minus_loc (loc_of_data obj ga) (loc_of_data obj gb)) + | _ -> WpLog.fatal "wrong parameters for pointer arithmetics" + end + + ( scalar arithmetics ) + + | PlusA | MinusA | Mult | Div | Mod + | BAnd | BXor | BOr | Shiftlt | Shiftrt -> + begin + match kr with + | (Kint | Kcint _) -> data_of_integer + (int_op binop + (integer_of_data ka ga) (integer_of_data kb gb)) + | Kreal -> data_of_real + (real_op binop (real_of_data ka ga) (real_of_data kb gb)) + | (Kset Kint |Kset (Kcint _)) when binop = PlusA -> + add_integer ka ga kb gb + | _ -> WpLog.fatal "wrong parameters for scalar arithmetics" + end + + ( comparisons ) + | Eq | Ne | Gt | Ge | Lt | Le -> + data_of_boolean (data_cmp binop ka ga kb gb) + + (logic or ) + | LOr -> + data_of_boolean (F.e_or (boolean_of_data ga) (boolean_of_data gb)) + + ( logic and ) + | LAnd -> + data_of_boolean (F.e_and (boolean_of_data ga) (boolean_of_data gb)) + + ( ------------------------------------------------------------------------ ) + ( --- Unary Operators --- ) + ( ------------------------------------------------------------------------ ) + + let data_unop kr unop ka ga = + match unop with + | Neg -> + begin + match kr with + | (Kint | Kcint _) -> + data_of_integer (F.e_ineg (integer_of_data ka ga)) + | Kreal -> data_of_real (F.e_rneg (real_of_data ka ga)) + | _ -> WpLog.fatal + "wrong type of parameter for negation operator" + end + | LNot -> + let b = + match kr with + |(Kint | Kcint _)-> + F.e_icmp Ceq (integer_of_data ka ga) (F.e_icst "0") + |Kreal -> F.e_rcmp Ceq (real_of_data ka ga) (F.e_rcst "0.0") + |Kptr ty -> + let obj = object_of ty in + M.is_null (loc_of_data obj ga) + | Kbool -> + F.e_not (boolean_of_data ga) + | k -> WpLog.fatal + "%a : wrong type of parameter for logic not operator" pp_kind k + in data_of_boolean b + | BNot -> + begin + match kr with + | (Kint | Kcint _) -> + data_of_integer (F.e_bnot (integer_of_data ka ga)) + | _ -> WpLog.fatal + "wrong type of parameter for bitwise not operator" + end + + ( ------------------------------------------------------------------------ ) + ( --- Constants --- ) + ( ------------------------------------------------------------------------ ) + + let data_const = function + | CInt64(k,_,_) -> + data_of_integer (F.e_icst (My_bigint.to_string k)) + + | CChr c -> + data_of_integer (F.e_icst (Int64.to_string (Ctypes.char c))) + + | CReal(f,_,_) -> + data_of_real (F.e_rcst (string_of_float f)) + + | CEnum e -> + let machdep = true in + let e' = Cil.constFold machdep e.eival in + begin + match e'.enode with + | Const CInt64(k,_,_) -> + data_of_integer (F.e_icst (My_bigint.to_string k)) + | Const CChr c -> + data_of_integer (F.e_icst (string_of_int (Char.code c))) + | _ -> WpLog.fatal "unrecognized sizeof/alignof " + end + | CWStr _ -> + WpLog.not_yet_implemented "wide character string constant" + | CStr s -> + WpLog.not_yet_implemented "character string constant (%S)" s + + ( ------------------------------------------------------------------------ ) + ( --- Terms --- ) + ( ------------------------------------------------------------------------ ) + + let rec data_of_term env term = + match term.term_node with + + ( Constants ) + | TConst c -> data_const c + + ( Operators ) + + | TUnOp (unop,a) -> + data_unop (kind_of term.term_type) unop + (kind_of a.term_type) (data_of_term env a) + + | TBinOp(binop,a,b) -> + data_binop + (kind_of term.term_type) binop + (kind_of a.term_type) (data_of_term env a) + (kind_of b.term_type) (data_of_term env b) + + ( L-Values ) + + | TLval(TResult _ ,off) -> + logic_offset env (F.var(result env.frame)) off + + | TLval (TVar{lv_name = "\\exit_status"},_) -> + Data (F.var (status env.frame)) + + | TLval (TVar lv,off) -> + begin + match lvar env lv with + | Logic_cvar x -> + let tr,gloc = gaddress_of_cvar env x off in + data_load env tr gloc + | Logic_value (M.V_pointer(ty,loc)) -> + Loc (loc_offset env loc ty off) + | Logic_value v -> + let t = M.logic_of_value v in + logic_offset env t off + | Logic_term t -> + logic_offset env t off + | Logic_var x -> logic_offset env (F.var x) off + | Logic_byref -> gaddress_of_ref env lv off + end + + | TLval(TMem e,off) -> + let tr,gloc = gaddress_of_mem env e off in + data_load env tr gloc + + | TAddrOf(TVar{lv_origin=Some x},off) -> + begin + match xvar env x with + | None -> snd (gaddress_of_cvar env x off) + | Some v -> snd (memory_offset env x.vtype (Value v) off) + end + + | TStartOf(TVar{lv_origin=Some x},off) -> + begin + match xvar env x with + | None -> gstartof_cvar env x off + | Some v -> gstartof_value env x.vtype v off + end + + | TAddrOf(TMem e,off) -> + snd (gaddress_of_mem env e off) + | TStartOf(TMem e,off) -> + gstartof_mem env e off + + | TAddrOf(TResult _,_) + | TStartOf(TResult _,_) -> WpLog.not_yet_implemented "&\\result" + + | TAddrOf(TVar {lv_origin=None},_) -> + WpLog.fatal "taking address of a logic variable" + + | TStartOf(TVar {lv_origin=None},_) -> + WpLog.not_yet_implemented "reference to a logic array" + + ( At ) + + | Tat(t,label) -> data_of_term (env_at env (c_label label)) t + + ( Sizeof and alignment ) + + | TSizeOf _ + | TSizeOfE _ + | TSizeOfStr _ + | TAlignOf _ + | TAlignOfE _ -> + let machdep = true in + let e' = Cil.constFoldTerm machdep term in + begin + match e'.term_node with + | TConst _ -> data_of_term env e' + | _ -> WpLog.fatal "unrecognized sizeof/alignof (%a)" + !Ast_printer.d_term term + end + + ( Conditional ) + + | Tif (b, t, f) -> + Data + (F.e_cond (boolean_of_data (data_of_term env b)) + (term_of_data (data_of_term env t)) + (term_of_data (data_of_term env f))) + + ( Memory call ) + + | Tbase_addr t -> + let obj = match t.term_type with + | Ctype ty -> object_of ty + | _ -> WpLog.fatal "Base-address of logic type object" + in + Loc (M.base_address + (mem_at_env env) + (loc_of_data obj (data_of_term env t))) + + | Tblock_length t -> + let obj = match t.term_type with + | Ctype ty -> object_of ty + | _ -> WpLog.fatal "Block-length of logic type object" + in + data_of_integer + (M.block_length + (mem_at_env env) + (loc_of_data obj (data_of_term env t))) + + ( Range ) + + | Trange (ti,tj ) -> + let option_int env = function + | None -> None + | Some x -> Some (integer_of_data (kind_of x.term_type) + (data_of_term env x)) + in + let r = {F.inf =(option_int env ti); + F.sup =(option_int env tj)} in + Interval r + + | Tempty_set -> List [] + + | Tunion xs -> union_map (data_of_term env) xs + + + | Tinter(a::b) -> + Set (List.fold_left + (fun s1 s2 -> + F.inter s1 (set_of (data_of_term env s2))) + (set_of (data_of_term env a)) b) + + | Tinter [] -> WpLog.fatal "empty intersection" + + | Tcomprehension (_, _, _) -> + WpLog.not_yet_implemented "Set comprehension" + + ( Conversions ) + + | Tnull -> Loc M.null + + | TCastE (ty,t) -> + if Cil.isPointerType ty && Cil.isLogicZero t then + Loc M.null + else + cast (data_of_term env t) (kind_of t.term_type) (kind_of_typ ty) + + ( Logic ADT ) + + | TUpdate (_,TNoOffset,tv) -> + data_of_term env tv + + | TUpdate (r,TField (f, TNoOffset),tv) -> + begin + match kind_of (r.term_type) with + | Kstruct _ -> + let record = record_of_data (data_of_term env r) in + let v = term_of_data (data_of_term env tv) in + let r = F.upd_field record f v in + Data (F.wrap r) + + | _ -> + WpLog.fatal "Functional update of a non-record value" + end + + | TUpdate (r,TIndex(k, TNoOffset),tv) -> + begin + match kind_of (r.term_type) with + | Karray _ -> + let array = array_of_data (data_of_term env r) in + let idx = integer_of_data (kind_of k.term_type) + (data_of_term env k) in + let v = term_of_data (data_of_term env tv) in + let r = F.upd_index array idx v in + Data (F.wrap r) + + | _ -> + WpLog.fatal "Functional update of a non-array value" + end + + | TUpdate (_,_,_) -> + WpLog.not_yet_implemented "ACSL extension for functional update" + + | TDataCons({ctor_name="\\true"},[]) -> Data(F.wrap F.e_true) + | TDataCons({ctor_name="\\false"},[]) -> Data(F.wrap F.e_false) + + | TDataCons (c,_) -> + WpLog.not_yet_implemented "Constructor (%s)" c.ctor_name + + ( Jessie ) + | TCoerce (_,_) + | TCoerceE (_,_) -> + WpLog.fatal "Only produced by Jessie plugin" + + ( Type ) + + | Ttypeof _ + | Ttype _ -> + WpLog.not_yet_implemented "Type Tag" + + ( Let binding ) + + | Tlet (({l_var_info =x; + l_labels=[];l_tparams=[]; + l_profile =[];l_body=(LBterm t1); l_type=Some _ } as linfo),t2) -> + if Logic_env.Logic_builtin_used.mem linfo then + Wp_parameters.not_yet_implemented "Built-ins symbols" + else + let var,env2 = bind_fresh env x in + let t1' = term_of_data (data_of_term env t1) in + let t2' = term_of_data (data_of_term env2 t2) in + Data (F.e_subst L.alpha var t1' t2') + | Tlet _ -> + WpLog.not_yet_implemented + "Complex Let-binding" + + ( Logic-Function Call ) + + | Tapp (lfun,labels,args) -> + if Logic_env.Logic_builtin_used.mem lfun then + Wp_parameters.not_yet_implemented "Built-ins symbols" + else + Data (!rec_apply_function env lfun labels args) + + ( Higer order function ) + + | Tlambda (_,_) -> + WpLog.not_yet_implemented "Higher order functions" + + let () = data_rec := data_of_term + + let term env t = term_of_data (data_of_term env t) + + ( ------------------------------------------------------------------------ ) + ( --- Assignable --- ) + ( ------------------------------------------------------------------------ ) + + let rec data_of_assignable env t= + match t.term_node with + + | TLval (TVar{lv_origin=Some x}, off) -> + begin + match xvar env x with + | None -> snd (gaddress_of_cvar env x off) + | Some v -> Value v + end + + | TLval (TMem e, off) -> + snd (gaddress_of_mem env e off) + + | TStartOf (TVar{lv_origin=Some x}, off) -> + begin + match xvar env x with + | None -> gstartof_cvar env x off + | Some v -> gstartof_value env x.vtype v off + end + + | TStartOf (TMem e, off) -> gstartof_mem env e off + + | Tempty_set | TLval (TResult _, _ )-> List [] + + | Tat(t ,lab) -> data_of_assignable (env_at env (c_label lab)) t + + | TBinOp((IndexPI | PlusPI),a,b) -> + data_shift + (kind_of a.term_type) (data_of_term env a) + (kind_of b.term_type) (data_of_term env b) + ~is_pos:true + + | TBinOp (MinusPI,a,b) -> + data_shift + (kind_of a.term_type) (data_of_term env a) + (kind_of b.term_type) (data_of_term env b) + ~is_pos:false + + | Tunion ts -> union_map (data_of_assignable env) ts + | Tinter (t::ts) -> + let f t = set_of (data_of_assignable env t) in + Set(List.fold_left + (fun s t -> F.inter s (f t)) (f t) ts) + | Tinter [] -> WpLog.fatal "empty intersection" + + | TStartOf (TResult _, _ ) + | Tlet (_, _) | Tcomprehension (_, _, _) + | Tif (_, _, _) | Tapp (_, _, _) | TCastE (_, _) + + -> WpLog.not_yet_implemented "assignation of (%a)" + !Ast_printer.d_term t + + | TLval (TVar {lv_origin=None}, _) + | TAddrOf _ + | TStartOf (TVar {lv_origin=None}, _) + | Trange (_, _)|Ttype _|Ttypeof _|TCoerceE (_, _)|TCoerce (_, _) + | TUpdate (_, _, _)|Tblock_length _ + | TDataCons (_, _)|Tlambda (_, _) + | TUnOp (_, _)|TAlignOfE _|TAlignOf _|TSizeOfStr _|TSizeOfE _|TSizeOf _ + | TConst _ | Tnull | Tbase_addr _ + | TBinOp( + (LOr|LAnd|BOr|BXor|BAnd|Ne|Eq|Ge|Le|Gt|Lt| + Shiftrt|Shiftlt|Mod|Div|Mult| + MinusPP|MinusA|PlusA),_,_) + -> WpLog.fatal "not assignable terms" + + let assigned env t = + ( (ZD) DO preserve this filter, as \empty is polymorphic! ) + match t.term_node with + | Tempty_set | TLval (TResult _, _ ) -> [] + | _ -> + let data = data_of_assignable env t in + let te = + match t.term_type with + | Ctype te -> te + | Ltype( {lt_name="set"} , [Ctype elt] ) -> elt + | _ -> WpLog.fatal + "unexpected logic-type for assignable term %a" + !Ast_printer.d_logic_type t.term_type + in + assigned_of_data (object_of te) [] data + + ( ------------------------------------------------------------------------ ) + ( --- Properties --- ) + ( ------------------------------------------------------------------------ ) + + let rec_apply_predicate + : (env -> logic_info -> + (logic_label logic_label) list -> term list -> F.pred) ref + = ref (fun _ _ _ _ -> assert false) + + let pred_cmp binop ka ga kb gb = + match ka,kb with + | (Kint | Kcint _) , (Kint | Kcint _) -> + pint_cmp binop (integer_of_data ka ga) (integer_of_data kb gb) + | (Kreal|Kint| Kcint _) , (Kreal|Kint| Kcint _) -> + preal_cmp binop (real_of_data ka ga) (real_of_data kb gb) + | Kptr ty , Kptr _ -> + let obj = object_of ty in + ptr_rel binop (loc_of_data obj ga) (loc_of_data obj gb) + | Kstruct s, Kstruct s' when (s.Cil_types.ckey=s'.Cil_types.ckey) -> + M.eq_record s (record_of_data ga) (record_of_data gb) + | Karray arr, Karray arr' when Ctypes.AinfoComparable.equal arr arr' -> + M.eq_array arr (array_of_data ga) (array_of_data gb) + | _ -> + begin + match binop with + | Eq -> F.p_eq (term_of_data ga) (term_of_data gb) + | Ne -> F.p_not (F.p_eq (term_of_data ga) (term_of_data gb)) + | _ -> WpLog.fatal ~current:true "Unexpected comparison" + end + + let rec prop env p = + List.fold_right F.p_named p.name (prop_body env p) + + and prop_body env p = + match p.content with + | Pfalse -> F.p_false + + | Ptrue -> F.p_true + + | Pand(p1,p2) -> + F.p_and (prop env p1)(prop env p2) + + | Por(p1,p2) -> + F.p_or (prop env p1)(prop env p2) + + | Pxor(p1,p2) -> + (TODO : no primitive translation for XOR in WHY ) + (Infact in bool.why there is bool_xor ) + F.p_xor(prop env p1)(prop env p2) + + | Pimplies(p1,p2) -> + F.p_implies(prop env p1)(prop env p2) + + | Piff(p1,p2)-> + F.p_iff(prop env p1)(prop env p2) + + | Pnot p -> F.p_not (prop env p) + + | Pif(c,pt,pf) -> + F.p_cond (F.unwrap (term env c)) + (prop env pt) + (prop env pf) + + | Pat (p,l) -> prop (env_at env (c_label l)) p + + | Prel ( rel ,t1,t2) -> + let ct1 = kind_of t1.term_type in + let ct2 = kind_of t2.term_type in + let m1 = data_of_term env t1 in + let m2 = data_of_term env t2 in + pred_cmp (rel_op rel) ct1 m1 ct2 m2 + + | Pvalid t -> + let k = kind_of t.term_type in + let d = data_of_term env t in + data_valid (mem_at_env env) k d + + | Pvalid_index(tp,ti) -> + let ty = match tp.term_type with + | Ctype te -> te + | _ -> WpLog.fatal "expected a non logic type" + in + let kp = kind_of_typ ty in + let ki = kind_of ti.term_type in + let dp = data_of_term env tp in + let di = data_of_term env ti in + if Cil.isArrayType ty then + let te = Cil.typeOf_array_elem ty in + let ta = object_of te in + let d = data_index ta kp dp ki di in + data_valid (mem_at_env env) kp d + else + if Cil.isPointerType ty then + let d = data_shift kp dp ki di ~is_pos:true in + data_valid (mem_at_env env) kp d + else WpLog.fatal "unexepected type for valid index" + + | Pvalid_range(b,l,h) -> + let tb = b.term_type in + let k = kind_of tb in + begin + match k with + | Kptr _ -> + let ty = typ_of_elements tb in + let obj = object_of ty in + let loc = loc_of_data obj (data_of_term env b) in + let rg = { + F.inf = Some (integer_of_data (kind_of l.term_type) + (data_of_term env l)); + F.sup = Some (integer_of_data (kind_of h.term_type) + (data_of_term env h)); + } in + M.valid (mem_at_env env) (F.Arange(obj,loc,rg)) + | _ -> WpLog.fatal "unsuitable argument for [valid_range]" + end + + | Pfresh _t -> WpLog.not_yet_implemented "fresh" + + | Pinitialized _t -> WpLog.not_yet_implemented "initialized" + + | Psubtype (_t1,_t2) -> WpLog.not_yet_implemented "subtype" + + | Plet(def, p) -> + begin + let lv = def.l_var_info in + match def.l_body, def.l_profile with + LBterm t, [] -> + let x = fresh_local lv in + L.subst x (term env t) + (prop (bind_lvar env lv (F.var x)) p) + | _ -> WpLog.not_yet_implemented "local binding" + end + + | Pforall (xs,p) -> + let freshes = List.map (fun x -> x , fresh_local x) xs in + let quantified = List.map snd freshes in + let assoc = List.map (fun (x,v) -> x,F.var v) freshes in + L.forall quantified (prop (bind_lvars env assoc) p) + + | Pexists (xs,p) -> + let freshes = List.map (fun x -> x , fresh_local x) xs in + let quantified = List.map snd freshes in + let assoc = List.map (fun (x,v) -> x,F.var v) freshes in + L.exists quantified (prop (bind_lvars env assoc) p) + + | Pseparated tl -> + let gs = + List.map + (fun t -> + let te = + match kind_of t.term_type with + | Kptr te -> te + | Kset (Kptr te) -> te + | k -> WpLog.fatal "separated on non pointer type : %a " pp_kind k + in + Ctypes.object_of te, data_of_term env t) tl in + let ags = Array.of_list gs in + let p = ref F.p_true in + let m = mem_at_env env in + for i=0 to Array.length ags - 2 do + for j=i+1 to Array.length ags - 1 do + p := F.p_and !p (data_separated m ags.(i) ags.(j)) + done + done ; + !p + + | Papp (predicate,labels,args) -> + if Logic_env.Logic_builtin_used.mem predicate then + Wp_parameters.not_yet_implemented "Built-ins symbol %a (%d)" + !Ast_printer.d_logic_var predicate.l_var_info predicate.l_var_info.lv_id + else + !rec_apply_predicate env predicate labels args + + + + + (* ------------------------------------------------------------------------ ) + ( --- Accessing User-Definitions --- ) + ( ------------------------------------------------------------------------ ) + + let get_definition cc fdef = + let xdef = fdef.l_var_info in + try Hdef.find user_definitions xdef + with Not_found -> + UserDefinition.lock xdef ; + try + let udef , items = cc fdef in + Hdef.add user_definitions xdef udef ; + UserDefinition.define udef items ; udef + with error -> + UserDefinition.unlock xdef ; raise error + + ( ----------------------------------------------------------------------- ) + ( --- Compilation of User-defined Predicate and Functions --- ) + ( ----------------------------------------------------------------------- ) + + let push_context where = + L.push where (F.pool()) L.closed + + let flush_context where context p = + L.flush where context p + + let kill_context where context = + L.kill where context + + let user_default_label = function + | [] -> Clabels.Here + | LogicLabel (None, first) :: _ -> Clabels.LabelParam first + | LogicLabel (Some _, _) :: _ -> + Wp_parameters.fatal + "Unexpected redefined labels in user-defined predicates" + | StmtLabel _ :: _ -> + Wp_parameters.fatal + "Unexpected stmt-labels in user-defined predicates" + + let user_env pdef = + let context = push_context "user" in + try + let frame = user_frame () in + let lvars = ref Logic_var.Map.empty in + let laddr = ref Logic_var.Map.empty in + let profile = List.map + (fun lv -> + if M.userdef_is_ref_param lv then + begin + lvars := Logic_var.Map.add lv Logic_byref !lvars ; + let opt_cx = + if M.userdef_ref_has_cvar lv + then + let x = fresh_addr lv in + laddr := Logic_var.Map.add lv x !laddr ; + Some x else None + in + UF_references ( lv ,opt_cx, [] ) ( initially empty ) + end + else + begin + let x = fresh_local lv in + lvars := Logic_var.Map.add lv (Logic_term (F.var x)) !lvars ; + UF_logic ( lv , x ) + end) + pdef.l_profile + in + let env = { + formals_in_pre = false ; + frame = frame ; + label = user_default_label pdef.l_labels ; + lvars = !lvars ; + xvars = Varinfo.Map.empty ; + laddr = !laddr; + } + in ( context , profile , env ) + with err -> + kill_context "user env" context; raise err + + let collect_signature profile filter env = + let closures = ref [] in + let references = ref Logic_var.Map.empty in + let get_refs lv refs = + try Logic_var.Map.find lv refs + with Not_found -> [] + in + Lmap.iter + (fun label mem -> + match label with + | LabelParam label -> + begin + ( Collecting reference parameters ) + List.iter + (fun (x,lv,formal) -> if filter x then + let refs = + (x,formal,label) :: (get_refs lv !references) in + references := Logic_var.Map.add lv refs !references) + (M.userdef_ref_signature mem) ; + ( Collecting memory parameters ) + List.iter + (fun (x,clos) -> if filter x then + closures := UF_closure(x,clos,label) :: !closures) + (M.userdef_mem_signature mem) ; + end + | _ -> ()) + env.frame.states ; + begin + List.rev !closures @ + List.map + (function + | (UF_logic _ | UF_closure _) as p -> p + | UF_references(lv,opt_cx,_) -> + UF_references(lv, opt_cx, List.rev (get_refs lv !references)) + ) profile + end + + ( WARNING: should be the same order of binding that apply_formals ) + let rec flatten_formals = function + | [] -> [] + | UF_logic(_,x)::ufs -> x :: flatten_formals ufs + | UF_closure(x,_,_)::ufs -> x :: flatten_formals ufs + | UF_references(_,None,refs)::ufs -> flatten_references refs ufs + | UF_references(_,Some x,refs)::ufs -> x :: flatten_references refs ufs + + and flatten_references refs ufs = + match refs with + | [] -> flatten_formals ufs + | (x,_,_)::refs -> x :: flatten_references refs ufs + + let all_filter (_:F.var) = true + let term_filter t x = F.term_has_var [x] t + let pred_filter p x = F.pred_has_var [x] p + + let compile_predicate pdef = + let o_name = Fol_decl.identifier (pdef.l_var_info.lv_name) in + let p_name = "D_" ^ o_name in + let d_name = "Def_" ^ o_name in + let context, profile, env = user_env pdef in + try + let body,filter = + match pdef.l_body with + | LBpred named -> + let v = prop env named in Some v , pred_filter v + | LBterm def -> + let v = term env def in Some (F.p_bool (F.unwrap v)) , term_filter v + | LBnone -> + Wp_parameters.warning ~once:true ~current:false + "No definition for '%s' interpreted as reads nothing" o_name ; + None , all_filter + | LBreads xs -> + (TODO: Below is an incorrect translation (LC+BM) (Idem for "\from") + (LC) Reason : xs are to be interpreted as left-values. + (Use case : f reads t[0..n]) + let vs = List.map (fun x -> term env x.it_content) xs in + None,vs,[] + ) + Wp_parameters.warning ~once:true ~current:false + "Interpreting reads-definition as expressions rather than tsets" ; + List.iter (fun x -> ignore (term env x.it_content)) xs ; + None , all_filter + | LBinductive _ -> + Wp_parameters.not_yet_implemented "Inductive predicates" + in + let signature = collect_signature profile filter env in + let formals = flatten_formals signature in + let declaration = + p_name , Formula.Predicate(List.map F.tau_of_var formals) in + let definitions = + match body with + | None -> kill_context "compile" context ; [] + | Some body -> + let p_axiom = + L.forall formals + (F.p_iff + (F.p_call p_name (List.map F.var formals)) + (flush_context "compile" context body)) + in + [ d_name , Formula.Axiom p_axiom ] + in + { + d_info = pdef ; + d_callname = p_name ; + d_formals = signature ; + } , + declaration :: definitions + with err -> + kill_context "compile" context ; + raise err + + let compile_function fdef = + let o_name = Fol_decl.identifier (fdef.l_var_info.lv_name) in + let f_name = "D_" ^ o_name in + let d_name = "Def_" ^ o_name in + let context, profile, env = user_env fdef in + try + let body,filter = + match fdef.l_body with + | LBterm def -> + let v = term env def in Some v , term_filter v + | LBreads xs -> + (TODO: Incorrect translation (Cf. predicates) + None,List.map (fun x -> term env x.it_content) xs + ) + Wp_parameters.warning ~once:true ~current:false + "Interpreting reads-definition as expressions rather than tsets" ; + List.iter (fun x -> ignore (term env x.it_content)) xs ; + None , all_filter + | LBnone -> + Wp_parameters.warning ~once:true ~current:false + "No definition for '%s' interpreted as reads nothing" o_name ; + None , all_filter + | LBinductive _ -> + Wp_parameters.fatal "Inductive function" + | LBpred _ -> + Wp_parameters.fatal "Function defined by a predicate" + in + let ltyp = + match fdef.l_type with + | Some ltyp -> ltyp + | None -> Wp_parameters.fatal "Function defined with not result type" + in + let t_result = M.tau_of_logic_type ltyp in + let signature = collect_signature profile filter env in + let formals = flatten_formals signature in + let declaration = + f_name , Formula.Function(List.map F.tau_of_var formals,t_result) in + let call_f = F.e_call f_name (List.map F.var formals) in + let definitions = + match body with + | None -> kill_context "compile" context ; [] + | Some def -> + let f_axiom = F.p_forall formals + (flush_context "compile" context (F.p_eq call_f def)) + in + [ d_name , Formula.Axiom f_axiom ] + in + let guards = + let cond = L.has_type call_f ltyp in + if F.is_true cond then [] + else [ f_name ^ "_result" , Formula.Axiom (L.forall formals cond) ] + in + { + d_info = fdef ; + d_callname = f_name ; + d_formals = signature ; + } , + declaration :: (definitions @ guards) + with err -> + kill_context "compile" context ; + raise err + + ( ----------------------------------------------------------------------- ) + ( --- Compilation of User-defined Axiom --- ) + ( ----------------------------------------------------------------------- ) + + let axiom_env here = + let frame = user_frame () in + let here = Clabels.LabelParam here ( Non-expected ! ) in + { + formals_in_pre = false ; + frame = frame ; + label = here ; + lvars = Logic_var.Map.empty ; + xvars = Varinfo.Map.empty ; + laddr = Logic_var.Map.empty ; + } + + let compile_user_axiom _name predicate = + let context = push_context "axiom" in + try + let env = axiom_env "WP_nowhere" in + let def = prop env predicate in + flush_context "axiom" context def + with err -> + kill_context "axiom" context ; + raise err + + let compile_user_axiom_labels name (labels,predicate) = + let d_name = "Hyp_" ^ name in + let context = push_context "axiom-labels" in + try + let here = + match labels with + | LogicLabel (None, l)::_ -> l + | _ -> Wp_parameters.fatal "No logic label for Axiom '%s'" name + in + let env = axiom_env here in + let body = prop env predicate in + let signature = collect_signature [] (pred_filter body) env in + let formals = flatten_formals signature in + let property = L.forall formals (flush_context "axiom-labels" context body) + in { + a_name = name ; + a_defname = d_name ; + a_memory = signature ; + a_property = property ; + } + with err -> + kill_context "axiom-labels" context ; + raise err + + let compile_and_define hdefs name data compiler definer = + let cdata = + try Hashtbl.find hdefs name with Not_found -> + try + let cdata = Some (compiler name data) in + Hashtbl.add hdefs name cdata ; cdata + with error -> + Hashtbl.add hdefs name None ; raise error + in match cdata with + | None -> () + | Some data -> definer name data + + let add_axiom name labels predicate = + if not (UserAxiomDefs.is_defined name) then + if labels = [] then + compile_and_define user_axioms name predicate + compile_user_axiom + (fun name _ -> UserAxiom.define name) + else + compile_and_define user_axiomlabels name (labels,predicate) + compile_user_axiom_labels + (fun _ axdef -> UserAxiomDefs.define axdef) + + ( ------------------------------------------------------------------------ ) + ( --- Applying Definitions --- ) + ( ------------------------------------------------------------------------ ) + + ( Binds formal parameters to their actual arguments ) + ( - ufs: user_formal list ) + ( - dargs: data list ) + ( - returns: F.abstract list ) + + ( WARNING: apply_formals must bind formals in the same way that + flatten_formals collect the formals ) + + let bool_of_option = function Some _ -> true | None -> false + + let rec apply_formals env labels ufs dargs = + let s = "[apply_formals]" in + match ufs , dargs with + | [] , [] -> [] + | [] , d :: _ -> + Wp_parameters.fatal + "WP.UserDefs: signature mismatch (args) to much args %a" + pp_data d ; + | UF_logic (lv,_) :: ufs_tail , data :: dargs_tail -> + debug "%s : %a binds to %a, ufs_tail:%d, darg_tail:%d" + s !Ast_printer.d_logic_var lv pp_data data + (List.length ufs_tail) (List.length dargs_tail); + term_of_data data :: apply_formals env labels ufs_tail dargs_tail + | UF_logic (lv,_) :: _ , [] -> + Wp_parameters.fatal + "WP.UserDefs: signature mismatch (args) %a have no value" + !Ast_printer.d_logic_var lv; + | UF_closure(_,closure,at) :: ufs_tail , _ -> + let label = Clabels.lookup labels at in + let mem = mem_at env label in + let varg = M.userdef_mem_apply mem closure in + varg :: apply_formals env labels ufs_tail dargs + + | UF_references(_,_,_)::_ , [] -> + Wp_parameters.fatal "WP.UserDefs: signature mismatch (refs)" + + | UF_references(_,None,refs)::ufs_tail , data::dargs -> + apply_references env labels refs data ufs_tail dargs + + | UF_references(_,Some _,refs)::ufs_tail , data::dargs -> + let loc = + match data with + | Value(M.V_pointer(_,loc)) -> loc + | Loc loc -> loc + | _ -> Wp_parameters.fatal "WP.UserDefs: no reference found" + in + let inner_loc = M.inner_loc loc in + debug "%s the location of %a : %a the C loc : %a" s + pp_data data M.pp_loc loc F.pp_term inner_loc; + + inner_loc :: apply_references env labels refs data ufs_tail dargs + + + and apply_references env labels refs data ufs dargs = + match refs with + | [] -> apply_formals env labels ufs dargs + + | (_,formal,at) :: refs_tail -> + let loc = + match data with + | Value(M.V_pointer(_,loc)) -> loc + | Loc loc -> loc + | _ -> Wp_parameters.fatal "WP.UserDefs: no reference found" + in + let label = Clabels.lookup labels at in + let mem = mem_at env label in + let value = M.logic_of_value (M.userdef_ref_apply mem formal loc) in + value :: apply_references env labels refs_tail data ufs dargs + + let apply_predicate env def labels args = + let definition = get_definition compile_predicate def in + let arguments = List.map (data_of_term env) args in + let bindings = apply_formals env labels definition.d_formals arguments in + F.p_call definition.d_callname bindings + + let apply_function env def labels args = + let definition = get_definition compile_function def in + let arguments = List.map (data_of_term env) args in + let bindings = apply_formals env labels definition.d_formals arguments in + F.e_call definition.d_callname bindings + + let () = + begin + rec_apply_predicate := apply_predicate ; + rec_apply_function := apply_function ; + end + +end + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/translate_prop.mli frama-c-20111001+nitrogen+dfsg/src/wp/translate_prop.mli --- frama-c-20110201+carbon+dfsg/src/wp/translate_prop.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/translate_prop.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,93 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ ) +( --- Translation of Term and Predicates --- ) +( ------------------------------------------------------------------------ *) + +open Ctypes +open Clabels +open Formula +open Cil_types + +module Create + (M : Mlogic.S) + + : +sig + + (** {2 Translation environments} *) + + type env + + val env: Kernel_function.t -> + ?m_here:M.mem -> + ?m_pre:M.mem -> + ?m_post:M.mem -> + ?x_result:M.F.var -> + unit -> env + + val env_at : env -> c_label -> env + val mem_at : env -> c_label -> M.mem + val find_mem : env -> c_label -> M.mem option + val subst_result : env -> M.value option -> M.F.pred -> M.F.pred + val result_type : env -> typ + val exit_status : env -> M.F.var + val call_pre : env -> Kernel_function.t -> M.value list -> M.mem -> env + + val call_post : + env -> Kernel_function.t -> M.value list -> M.mem -> M.mem -> + M.F.var option -> env + + val call_exit : + env -> Kernel_function.t -> M.value list -> M.mem -> M.mem -> + M.F.var -> env + + (** {2 Translation functions} *) + + (** to be used to retreive variable add through [add_logic_vars]. *) + val collect_logic_vars : env -> M.F.var list + val add_logic_vars : env -> M.F.pool -> logic_var list -> env + + ( [term e t] interprets the C terms [t] in memory model environment [e] + as a logic term.) + val term : env -> term -> M.F.abstract + + ( [prop e p] interprets an ACSL predicate as a logic predicats + in memory model environment [e]. ) + val prop : env -> predicate named -> M.F.pred + + (** Compiles an arbitrary term representing a set of left-values into a zone *) + val assigned : env -> Cil_types.term -> M.loc M.F.assigned list + + (** {2 Axiomatics management} *) + + (** Compile an axiom and add it to the list of global declarations. ) + val add_axiom : string -> Cil_types.logic_label list -> Cil_types.predicate named -> unit + +end + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/variables_analysis.ml frama-c-20111001+nitrogen+dfsg/src/wp/variables_analysis.ml --- frama-c-20110201+carbon+dfsg/src/wp/variables_analysis.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/variables_analysis.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,2159 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* + This analysis performs a classification of the variables of the input + program. The aim of this classification is to optimize the translation + of variables by WP: + 1) optimization of the by-reference call and + 2) functional variables. +) + +open Cil_types +open Cil + +let dkey = "var_analysis" ( debugging key) + +let debug = Wp_parameters.debug ~dkey + +let dkey = "var_kind" + +let oracle = Wp_parameters.debug ~dkey + +( -------------------------------------------------------------------------- ) +( --- Variable Analysis --- ) +( -------------------------------------------------------------------------- ) + + +( + At the end, the analysis associates an [var_kind] information to each + variables: + 1) [Fvar] functional variable, variable such as its address is never + taken, + + 2) [PRarg] by_pointer_reference argument, variable such as its + address is only taken in by reference calls (one or more), + + 3) [ARarg] by_array_reference argument, variable such as its + address is only taken in by array reference calls (one or more), + + 4) [PRpar n] by_pointer_reference parameter of arity , + variable which is a formal parameter use for a by reference call + and can be invoked in a chain of by reference call such as their + arity are less or equal than n, + + 5) [ARpar n] by_array_reference parameter of arity , + variable which is a formal parameter use for a by array reference + call and can be invoked in a chain of by array reference call + such as their arity are less or equal than n, + + 6) [Cvar] other variable. + +*) + +type var_kind = + Fvar | Cvar | PRarg | ARarg | PRpar of int | ARpar of int + + +(********************************************************************) +(* I - By reference call optimisation. ) +(******************************************************************) + +(* + A by pointer reference call is characterized by 2 facts : + 1p) the formal parameters [p] is of pointer type [..<n>..t], + p always occurs with <n>:[<n> p] except in call. + As call argument, + p can occurs with less than <n>: [<k>p], k<=n in case of + by pointer reference call (ie. if p has the characteristic of a + by pointer reference argument.) + + 2p) the by pointer reference argument [x] is a variable which + is not a formal parameter and which appears as argument + to the match place of a by pointer reference parameter, in one or + more of those patterns [by_pref_pattern]: + - &x+offset + - x+i with x of pointer type and + as +PI. + - <n>x, n <= stars(typ(x)) + + A by array reference call is characterized by 2 facts : + 1a) the formal parameters [p] is of pointer type [..<n>..t], + p always occurs with <n> indexes:[p<n>[i]] except in call. + As call argument, + p can occurs with less than <n> indexes: [p<k>[i]], k<=n in case of + by array reference call (ie. if p has the characteristic of a + by array reference argument.) + + 2a) the by array reference argument [x] is a variable which + is not a formal parameter and which appears as argument + to the match place of a by pointer reference parameter, in one or + more of those patterns [by_array_reference_pattern]: + - x+offset (StarOf) + - x<k>[], k <= bracket(typ(x)) . + - &(x+i) + ==+PI +) + + + +(********************************************************************) +(* Helper section with some smart constructors for ) +( patterns identifications *) +(********************************************************************) + +(* [stars_typ typ] accounts the number of * if typ is a pointer type.) +let rec stars_typ typ = + match Cil.unrollType typ with + | TPtr (typ,_) -> 1+ stars_typ (Cil.unrollType typ) + | TInt(_,_) | TFloat(_,_) | TFun _ | TEnum (_,_) | TComp (_,_,_) + | TArray (_,_,_,_) | TBuiltin_va_list _ | TVoid _ | TNamed _ -> 0 + +( [bracket_typ typ] accounts the number of [dim] if typ is an array + type. ) +let rec brackets_typ typ = + match Cil.unrollType typ with + | TArray (typ,_,_,_) -> 1+ brackets_typ (Cil.unrollType typ) + | TInt(_,_) | TFloat(_,_) | TFun _ | TEnum (_,_) | TComp (_,_,_) + | TPtr (_,_) | TBuiltin_va_list _ | TVoid _ | TNamed _ -> 0 + + +( [bracket_and_stars_typ typ] accounts the number of [dim] and the number of + pointer if typ is a pointer on array type. ) +let brackets_and_stars_typ typ = + let rec stars_and_elt typ = + match Cil.unrollType typ with + | TPtr (typ,_) -> + let (n,t) = stars_and_elt (Cil.unrollType typ) in + (n+1),t + | TInt(_,_) | TFloat(_,_) | TFun _ | TEnum (_,_) | TComp (_,_,_) + | TArray (_,_,_,_) + | TBuiltin_va_list _ | TVoid _ | TNamed _ as t-> (0,t) + in + let (n,t) = stars_and_elt typ in n+brackets_typ t + +( [stars_lv_typ] same as stars_typ on logic_type) +let stars_lv_typ = function | Ctype t -> stars_typ t | _ -> 0 + +( [brackets_lv_typ] same as brackets_typ on logic_type) +let brackets_lv_typ = function | Ctype t -> brackets_typ t | _ -> 0 + +let brackets_and_stars_lv_typ = + function | Ctype t -> brackets_and_stars_typ t | _ -> 0 + + + +( [stars_exp e] returns Some (x,ty,n) if e == <n>* x and ty is the type of the + entire inner lval else returns none. ) +let rec stars_exp = function + | Lval (Var x,off ) -> Some(x,Cil.typeOfLval (Var x,off),0) + | Lval (Mem e, _) -> + (match stars_exp (Cil.stripInfo e).enode with + | None -> None + | Some (x,ty,n) -> Some (x, ty ,n+1)) + | _ -> None + + +( [stars_term t] returns Some (x,ty,n) if t == <n>* x and ty is the + type of the entire inner lval else returns none. ) +let rec stars_term = function + | TLval (TVar lvar,off ) + | Tat ({term_node = + TLval (TVar lvar,off )}, _ ) -> + Some(lvar,(Cil.typeOfTermLval(TVar lvar,off ) ),0) + | TLval (TMem t,_ ) + | Tat ({term_node = + TLval (TMem t,_)}, _ ) -> + (match stars_term t.term_node with + | None -> None + | Some (x,ty,n) -> Some (x,ty,n+1)) + | _ -> None + +( [brackets_off off] returns Some n if off == <n>[] else returns none. ) +let rec brackets_off = function + | Index (_,off) -> + (match brackets_off off with + | Some n ->Some (1+n) + | None -> None ) + | NoOffset -> Some 0 + | _ -> None + +( [brackets_toff off] returns Some n if off == <n>[] else returns none. ) +let rec brackets_toff = function + | TIndex(_,toff) -> + (match brackets_toff toff with + | Some n ->Some (1+n) + | None -> None ) + | TNoOffset -> Some 0 + | _ -> None + +( [bracket_exp e] returns Some(x,n) if e == x<n>[] else returns none) +let bracket_exp = function + | Lval (Var x,off) -> + (match brackets_off off with + | Some n -> Some(x,n) + | None -> None) + | _ -> None + +( [bracket_term t] returns Some(x,n) if t == x<n>[] else returns none) +let bracket_term = function + | TLval (TVar x,off) + | Tat ({term_node = + TLval (TVar x,off)}, _ ) -> + (match brackets_toff off with + | Some n -> Some(x,n) + | None -> None) + | _ -> None + +( [delta_ptr e] returns Some x if e == x+i and x has pointer type + returns None ) +let delta_ptr = function + | BinOp ((PlusPI|MinusPI), + {enode = Lval (Var x,off)},_ , _ ) -> + Some (x, stars_typ (Cil.typeOfLval (Var x,off))) + | _ -> None + +( variante of delta_ptr on term; takes care of labelled term ) +let delta_ptr_term = function + | TBinOp((PlusPI|MinusPI),{term_node = TLval (TVar lvar,off)},_) + | Tat + ({term_node = + TBinOp((PlusPI|MinusPI),{term_node = TLval (TVar lvar,off)},_) + },_) + | TLval (TMem + {term_node = + Tat + ({term_node = + TBinOp((PlusPI|MinusPI), + {term_node = TLval (TVar lvar,off)},_) + },_)},_) + | TLval (TMem + {term_node = + TBinOp((PlusPI|MinusPI), + {term_node = Tat({term_node = TLval (TVar lvar,off)},_)},_)},_) + | TLval (TMem + {term_node = + TBinOp((PlusPI|MinusPI), + {term_node = TLval (TVar lvar,off)},_)},_) + | TBinOp((PlusPI|MinusPI), + {term_node = + TLval (TMem + {term_node = + Tat({term_node = TLval (TVar lvar,off)},_)},_)},_) + + -> Some (lvar, stars_lv_typ (Cil.typeOfTermLval (TVar lvar,off))) + | _ -> None + +( [delta_array e] returns Some x if e == x[i] and x has pointer type + else returns None *) +let delta_array = function + | BinOp (IndexPI,{enode = Lval (Var x,off)}, _ ,_) + -> Some (x, stars_typ (Cil.typeOfLval (Var x,off))) + | e -> debug "[delta_array] calls delta_ptr"; delta_ptr e + +let delta_array_term = function + | TBinOp(IndexPI,{term_node = TLval (TVar lvar,off)},_) + | Tat + ({term_node = TBinOp(IndexPI,{term_node = TLval (TVar lvar,off)},_) + },_) + | TLval (TMem + {term_node = + TBinOp(IndexPI,{term_node = TLval (TVar lvar,off)},_)} + , _) + | TLval (TMem + {term_node = Tat + ({term_node = TBinOp(IndexPI,{term_node = TLval (TVar lvar,off)},_) + },_)},_) + | TBinOp(IndexPI, + {term_node = + Tat({term_node = TLval (TVar lvar,off)},_)},_) + -> Some (lvar, stars_lv_typ (Cil.typeOfTermLval (TVar lvar,off))) + | t -> + debug "[delta_array_term] calls delta_ptr_term"; delta_ptr_term t + +(********************************************************************) +(* A - Identification of by reference formal parameters usage and ) +( Identification of reference argument by usage. ) +( and accounting of addresss taken of each variable ) +( We also protect the translation of pure logic variables bound ) +( by pforall and pexists. *) +(********************************************************************) +(* Table of logic parameters, parameters of logic functions and predicate. + The associated boolean is used to tagged the user parameters as + an argument of a ACSL builtin predicates or functions which + parameters are by reference: \valid and family, \block_length, + \separated, \initialized) +module LogicParam = + State_builder.Hashtbl + (Cil_datatype.Logic_var.Hashtbl) + (Datatype.Bool) + (struct let name = "WP : logic parameters" + let dependencies = [Ast.self] + let kind = `Internal + let size = 40 + end) + +let logic_param_memory_info x = + debug "[LogicParam] %a" !Ast_printer.d_logic_var x; + if LogicParam.mem x then + (debug "[LogicParam] %a in " !Ast_printer.d_logic_var x; + LogicParam.replace x true) + else + (debug "[LogicParam] %a out"!Ast_printer.d_logic_var x;()) + +( Type of ACSL Variable, C-variable or Logic Variable or Formal parameters + of builtin predicates/functions.) +type var_type = + | Cv of varinfo (C formal parameter) + | Lv of logic_var (Logic formal parameter) + | Prop (Parameter of valid or separated or initialized, + ie builtin predicate) + +( tests if a logic variable is a formal parameter.) +let is_lformal = function + | {lv_origin = Some x} -> x.vformal + | lv -> LogicParam.mem lv + +( according to a logicvar returns the more specified var_type) +let var_type_of_lvar = function + |{lv_origin = Some x} -> Cv x + | l -> Lv l + +let pp_var_type fmt = function + | Cv x -> !Ast_printer.d_var fmt x + | Lv p -> !Ast_printer.d_logic_var fmt p + | Prop -> Format.pp_print_string fmt "Prop" + +let brackets_var_type_typ = function + | Cv x -> brackets_typ x.vtype + | Lv lv -> brackets_lv_typ lv.lv_type + | Prop -> 0 + +let brackets_and_stars_var_type_typ = function + | Cv x -> brackets_and_stars_typ x.vtype + | Lv lv -> brackets_and_stars_lv_typ lv.lv_type + | Prop -> 0 + +let stars_var_type_typ = function + | Cv x -> stars_typ x.vtype + | Lv lv -> stars_lv_typ lv.lv_type + | Prop -> 0 + +let isVarTypePointerType =function + | Cv x -> Cil.isPointerType x.vtype + | Lv lv -> Logic_utils.isLogicPointerType lv.lv_type + | Prop -> false + +let is_formal_var_type = function + | Cv x -> x.vformal + | Lv lv -> LogicParam.mem lv + | Prop -> false + + + +module VarType = + (Datatype.Make_with_collections + (struct + include Datatype.Undefined + let name = "WpVarType" + type t = var_type + let reprs = + let cp_repr = List.hd Cil_datatype.Varinfo.reprs in + let lp_repr = List.hd Cil_datatype.Logic_var.reprs in + [Cv cp_repr ; Lv lp_repr ; Prop] + let equal a b = + match a,b with + | Cv a, Cv b -> Cil_datatype.Varinfo.equal a b + | Lv a, Lv b -> Cil_datatype.Logic_var.equal a b + | Prop, Prop -> true + | _ , _ -> false + + let compare a b = + match a,b with + | Cv a, Cv b -> Cil_datatype.Varinfo.compare a b + | Cv _ , _ -> (-1) + | _ , Cv _ -> (1) + | Lv a, Lv b -> Cil_datatype.Logic_var.compare a b + | Prop , Prop -> 0 + | Lv _ , _ -> (-1) + | _ , Lv _ -> (1) + + let hash = function + | Cv v -> (Cil_datatype.Varinfo.hash v)121 + | Lv p -> (Cil_datatype.Logic_var.hash p)147 + | Prop -> 147 + end)) + +(Table of other kind of variables ) +module AnyVar = + State_builder.Hashtbl + (VarType.Hashtbl) + (Datatype.Unit) + (struct let name = "WP: argument multi pattern" + let dependencies = [Ast.self] + let kind = `Internal + let size = 47 + end) + +( only used to records universally and existentially bound variables as + value variables. (ie. do not have to be optimized) ) +let add_logics_value l = + List.iter (fun lv -> AnyVar.replace (Lv lv) ()) l + + + + +( Table of variables which addresses are taken. + Each variable [x] is associated to a pair of integer (plus,minus) such as + [plus] is the total occurences of address taken of [x] and + [minus] is the number of occurences of address taken of [x] in + a by reference pattern. ) +module AddrTaken = + State_builder.Hashtbl + (VarType.Hashtbl) + (Datatype.Pair (Datatype.Int) (Datatype.Int)) + (struct let name = "WP: addr_taken" + let dependencies = [Ast.self] + let kind = `Internal + let size = 47 + end) + + +let string_addr b = if b then "address taken" else "not address taken" + +([incr_addr_taken var] adds [1] to the total occurences of address taken + of [var]) +let incr_addr_taken var = + debug "[incr_addr] %a" pp_var_type var; + oracle "[incr_addr] %a" pp_var_type var; + let (n,r) = try AddrTaken.find var with Not_found -> (0,0) in + AddrTaken.replace var (n+1,r) + +([decr_addr_taken var] adds [1] to the numbre of occurences of + address taken of [var] in by reference pattern) +let decr_addr_taken var = + debug "[decr_addr] %a" pp_var_type var; + oracle "[decr_addr] %a" pp_var_type var; + let (n,r) = try AddrTaken.find var with Not_found -> (0,0) in + AddrTaken.replace var (n,r+1) + +( variant occurs only if [b] is true else do nothing ) +let decr_addr_taken_bool var b = if b then decr_addr_taken var + + + +( Visitor which : + - collects the totale occurences of address taken ; + - collects all logic parameters ; + - collects all existentially and universally bound variables, as + variables which have not to be optimized. *) +class logic_parameters_and_addr_taken_collection : + Visitor.frama_c_visitor = object + inherit Visitor.frama_c_inplace + + method vexpr e = + match (Cil.stripInfo e).enode with + | StartOf (Var vinfo,_) + | AddrOf (Var vinfo,_) -> incr_addr_taken (Cv vinfo); DoChildren + | _ -> DoChildren + + method vterm t = + match t.term_node with + | TAddrOf(TVar lv,_) + | TStartOf(TVar lv,_) -> + incr_addr_taken (var_type_of_lvar lv); DoChildren + | _ -> DoChildren + + method vpredicate = function + | Pforall (xl,_) | Pexists (xl,_) -> + add_logics_value xl ; DoChildren + | _ -> DoChildren + + + method vannotation = function + | Dfun_or_pred (linfo,_) -> + List.iter (fun lv -> + oracle "[logicParam] %a" !Ast_printer.d_logic_var lv; + LogicParam.replace lv false) linfo.l_profile; + DoChildren + | _ ->DoChildren + + end + +let compute_logic_params () = + debug "[LP+AT] logic parameters and address taken computation"; + if not (LogicParam.is_computed()) || not (AddrTaken.is_computed()) then + ( Visitor.visitFramacFile + (new logic_parameters_and_addr_taken_collection)(Ast.get()); + LogicParam.mark_as_computed();AddrTaken.mark_as_computed()) + + + +(********************************************************************) +(* Parameters Tables *) +(********************************************************************) + +(* A [call] represents the binding at call time of an effective argument + to a formal parameter. A [call] is then a triplet : + - an arity using in the effective argument; + - a test of address taken in the effective argument; + - a vartype represented the the formal parameter. +) +( A [ChainCalls] is a list of [call]s. + For a vartype [x], a [ChainCalls] the list of all call binding + when [x] is (the root of) the effective argument.) +module ChainCalls = + (Datatype.List (Datatype.Pair (Datatype.Int) + (Datatype.Pair (Datatype.Bool)(VarType)))) + + +let pp_call fmt (n,(b,p)) = + Format.fprintf fmt "%a of arity:%d with %s " pp_var_type p n (string_addr b) + +let pp_chaincall l = (Pretty_utils.pp_list ~sep:";@, " pp_call) l + +( Table of the parameters of by pointer reference passing call ) +module ByPReference = + State_builder.Hashtbl + (VarType.Hashtbl) + (Datatype.Pair (Datatype.Int) (ChainCalls)) + (struct let name = "WP: by pointer reference parameters" + let dependencies = [Ast.self] + let kind = `Internal + let size = 47 + end) + +( Table of the parameters of by array reference passing call ) +module ByAReference = + State_builder.Hashtbl + (VarType.Hashtbl) + (Datatype.Pair (Datatype.Int) (ChainCalls)) + (struct let name = "WP: by array reference parameters" + let dependencies = [Ast.self] + let kind = `Internal + let size = 47 + end) + +( Table of the parameter of by value passing call ) +module ByValue = + State_builder.Hashtbl + (VarType.Hashtbl) + (Datatype.Unit) + (struct let name = "WP: by value parameters" + let dependencies = [Ast.self] + let kind = `Internal + let size = 47 + end) + +let is_pure_logic = function + | Lv lv -> (LogicParam.mem lv) && (lv.lv_origin = None) + | _ -> false + +([add_ptr_reference_param x n] tries to add the paramtype [x] with + an arity of [n] in the table of by pointer reference parameters. + - If [x] is already in the table 2 case : + * [n] does not the recorded arity the [x] is removed from + this table and added to the by value table. + * Else nothing has to be done + - If [x] is not in the table : + * [x] is in Byvalue table, nothing has to be done + * [x] is in the table of by array reference parameter, [x] + is removed from this table and puts in ByValue table. + * [x] is not already registered in any tables, then + [x] is registered in the by pointer reference parameter + with arity [n] and an empty chaincalls. +) +let add_ptr_reference_param x n = + oracle "[ByPRef] first step + (%a,%d)" pp_var_type x n; + if n = 0 && (is_pure_logic x) then + (ByPReference.remove x ; ByValue.replace x ()) + else ( + try + if not (fst(ByPReference.find x) = n) then + (oracle "[ByPRef] remove %a: ko arity -> + ByValue" pp_var_type x; + ByPReference.remove x ; ByValue.replace x ()) + else (oracle "[ByPRef] (%a,%d) already" pp_var_type x n;()) + with Not_found -> + oracle "[ByPRef] %a not yet"pp_var_type x; + if ByValue.mem x then + (oracle "[ByPRef] not add %a : byValue" pp_var_type x; ()) + else + (if ByAReference.mem x then + (oracle "[ByPRef] %a in byARef : remove -> add in ByValue" + pp_var_type x; + ByAReference.remove x;ByValue.replace x()) + else + (oracle "[ByPRef] add (%a,%d)" pp_var_type x n; + ByPReference.replace x (n,[]))) ) + + +([remove_ptr_reference_param x] tries to removed [x] from the + table of by pointer reference parameters. +) +let remove_ptr_reference_param x = + oracle "[ByPRef] remove %a" pp_var_type x; + if ByPReference.mem x then + ( oracle "[ByPRef] remove %a of ByPref" pp_var_type x; + ByPReference.remove x) ; + oracle "[ByPRef] add in ByValue %a"pp_var_type x; + ByValue.replace x () + + +([add_array_reference_param x n] tries to register [x] with arity [n] + in the table of by array reference parameters. + - If [x] already in this table : + [n] is not the correct arity : [x] is removed from this table + and add to the by value parameters table. + Else nothing has to be done + - If [x] is not yet in this table : + [x] is a by value parameter, nothing has to be done + [x] is a by pointer reference parameter then [x] is removed + from the table of by pointer reference parameter and adds to + the by array reference parameter. + [x] is not in any table, [x] is registered in the by array + reference parameters with arity [n] and the empty chaincall. + +NB : As the behavior of a by pointer reference parameter is included + in the behavior of a by array reference parameter; a vartype [x] + in ByPReference has to be "promoted" to the ByAReference table + in this function. + +) +let add_array_reference_param x n = + oracle "[ByARef] first step + (%a,%d)" pp_var_type x n; + try + if not (fst (ByAReference.find x) = n) then + (oracle "[ByARef] remove %a: ko arity" pp_var_type x; + ByAReference.remove x ; ByValue.replace x ()) + else (oracle "[ByARef] (%a,%d) already" pp_var_type x n;()) + with Not_found -> + oracle "[ByARef] %a not yet"pp_var_type x; + if ByValue.mem x then + (oracle "[ByARef] not add %a : byValue" pp_var_type x; ()) + else + begin + try let (_,calls) = ByPReference.find x in + oracle "[ByARef] %a in byPRef : promote to byAref" + pp_var_type x; + ByAReference.replace x (n,calls); ByPReference.remove x + with Not_found -> + (oracle "[ByARef] add (%a,%d)" pp_var_type x n; + ByAReference.replace x (n,[])) + end + +let remove_array_reference_param x = + oracle "[ByARef] remove %a" pp_var_type x; + if ByAReference.mem x then + (oracle "[ByARef] remove %a of ByAref" pp_var_type x; + ByAReference.remove x) ; + oracle "[ByARef] add in ByValue %a"pp_var_type x; + ByValue.replace x () + + + +(***********************************************************************) +(* Usage of formal parameter as by reference parameter out of call *) +(***********************************************************************) +type 'a usage = Ok of 'a | Ko of 'a | Any + +(* Invariant : + by_pointerXXX must always been called before by_arrayXXX + then by_pointer can never returns KO) + +( [by_pointer_reference_usage e] implemants 1p ) +let by_pointer_reference_usage e = + match stars_exp e with + | None -> Any + | Some (x,ty,n) -> + if x.vformal then + (if (stars_typ ty = n) then Ok (x,n) else Any) + else Any + +let by_pointer_reference_usage_term e = + match stars_term e with + | None -> Any + | Some (x,ty,n) -> + if (is_lformal x) then + (if (stars_lv_typ ty = n) then Ok (x,n) else Any) + else Any + +( [by_array_reference_usage e] implements 1a) +let by_array_reference_usage e = + let s = "[by_array_ref_usage]" in + debug "%s" s; + match delta_array e with + | None -> + (match bracket_exp e with + | None -> + debug "%s not a bracket pattern" s; + Any + | Some (x,n) -> + debug "%s %a[]<%d>" s !Ast_printer.d_var x n; + if x.vformal then + (debug "%s %a is a formal" s !Ast_printer.d_var x; + let arr = brackets_and_stars_typ x.vtype in + if (arr >= n) then + (debug "%s %a has dim %d ok!" s !Ast_printer.d_var x arr; + Ok (x,arr)) else + (debug "%s %a has dim %d when need %d ko!" + s !Ast_printer.d_var x arr n; + Ko(x,arr)) + ) + else + ( debug "%s %a is not a formal" s !Ast_printer.d_var x; + Any) ) + | Some (x,n) -> + debug "%s %a[]" s !Ast_printer.d_var x ; + if x.vformal then Ok (x,n) else Any + + +let by_array_reference_usage_term e = + let s = "[by_array_ref_usage_term]" in + debug "%s" s; + match delta_array_term e with + | None -> + (match bracket_term e with + | None -> + debug "%s not a bracket pattern" s; Any + | Some (x,n) -> + begin + debug "%s %a[]<%d>" s !Ast_printer.d_logic_var x n; + if (is_lformal x) then + ( debug "%s %a is a formal" s !Ast_printer.d_logic_var x; + let arr = brackets_and_stars_lv_typ x.lv_type in + if (arr >= n) then + (debug "%s %a has dim %d ok!" s + !Ast_printer.d_logic_var x arr ;Ok (x,arr)) + else + (debug "%s %a has dim %d when need %d ko!" + s !Ast_printer.d_logic_var x arr n + ;Ko (x,arr))) + else + ( debug "%s %a is not a formal" + s !Ast_printer.d_logic_var x;Any) + end) + + |Some (x,n) -> + debug "%s %a[]" s !Ast_printer.d_logic_var x ; + if is_lformal x then Ok (x,n) else Any + +([reference_parameter_usage e] implements the recognition of the patterns + of by reference parameters *) +let reference_parameter_usage e = + debug "[reference_parameter_usage]" ; + match by_pointer_reference_usage e with + | Ok(x,n) -> + debug " %a used as ptr reference param of arity %d" + !Ast_printer.d_var x n ; + add_ptr_reference_param (Cv x) n; true + | Ko(x,_) -> + debug " %a BADLY used as ptr reference param" + !Ast_printer.d_var x ; + remove_ptr_reference_param (Cv x); true + | Any -> + (match by_array_reference_usage e with + | Ok(x,n) -> + debug " %a used as array reference param of arity %d" + !Ast_printer.d_var x n ; + add_array_reference_param (Cv x) n ; true + | Ko(x,_) -> + debug " %a BADLY used as array reference param" + !Ast_printer.d_var x ; + remove_array_reference_param (Cv x);true + | Any -> (); false) + +let reference_parameter_usage_lval lv = reference_parameter_usage (Lval lv) + +let reference_parameter_usage_term e = + debug "[reference_parameter_usage_term]" ; + match by_pointer_reference_usage_term e with + | Ok(x,n) -> + debug " %a used as ptr reference param of arity %d" + !Ast_printer.d_logic_var x n ; + add_ptr_reference_param (var_type_of_lvar x) n ; true + | Ko(x,_) -> + debug " %a BADLY used as ptr reference param" + !Ast_printer.d_logic_var x ; + remove_ptr_reference_param (var_type_of_lvar x) ; true + | Any -> + (match by_array_reference_usage_term e with + | Ok(x,n) -> + debug " %a used as array reference param of arity %d" + !Ast_printer.d_logic_var x n ; + add_array_reference_param (var_type_of_lvar x) n ; true + | Ko(x,_) -> + debug " %a BADLY used as array reference param" + !Ast_printer.d_logic_var x ; + remove_array_reference_param (var_type_of_lvar x) ; true + | Any -> (); false) + + +(********************************************************************) +(* Parameters identification without call *) +(********************************************************************) + +(* This visitor dispatches all formal parameters according to their + usage in terms and expressions without inpecting the calls, + applications and application in ACSL builtin predicates and functions. +*) +class parameters_call_kind_analysis : Visitor.frama_c_visitor = object + inherit Visitor.frama_c_inplace + + method vinst = function + | Call (_ ,{enode =Lval(Var _,NoOffset)} , _,_) -> SkipChildren + | Set (lv,_,_) -> + if reference_parameter_usage_lval lv then SkipChildren else DoChildren + | _ -> DoChildren + + method vexpr e = + if reference_parameter_usage (Cil.stripInfo e).enode then SkipChildren + else DoChildren + + method vterm t = + match t.term_node with + | Tapp (_,_ , _) -> SkipChildren + | Tblock_length _ -> SkipChildren + | t1 -> + if reference_parameter_usage_term t1 then SkipChildren else DoChildren + + method vpredicate = function + | Papp (_, _, _) -> SkipChildren + | Pvalid _ | Pvalid_index(_,_) | Pvalid_range(_,_,_) + | Pinitialized _ | Pfresh _ | Pseparated _ -> SkipChildren + | _ -> DoChildren + +end + +let compute_parameters_usage () = + debug + "[Parameters Usage] logic parameters usage computation"; + debug + "[Parameters Usage] computing address taken and logic parameters first"; + compute_logic_params (); + if not (ByValue.is_computed()) || + not (ByPReference.is_computed() || not(ByAReference.is_computed())) + then + ( Visitor.visitFramacFile + (new parameters_call_kind_analysis)(Ast.get()); + ByPReference.mark_as_computed();ByAReference.mark_as_computed(); + ByValue.mark_as_computed()) + + +(***********************************************************************) +(* Usage of effective parameter in by reference call *) +(***********************************************************************) + + +(* [by_pointer_reference_pattern e] returns [Ok(x,b,n)] if [x] appears as + a root in [e] with arity [n] and a test of address taken [b]. + + A by pointer reference pattern is one a the following : + - &x+offset --> (x,true,arity of typ(x)) ; + - x+i with x of pointer type and + as +PI ----> (x,false, arity of typ(x+i)) + - <n>x, n < stars(typ(x)) ----> (x,false,n). + + else returns: + - [Any] when the pattern is not significant ; + - [Ko] when the pattern is clearly uncompatible with a + by pointer reference pattern. +) +let by_pointer_reference_pattern = function + | Lval (Var x,off) -> + let t = (Cil.typeOfLval (Var x,off)) in + if Cil.isPointerType t then + Ok (x,false, stars_typ t) + else Any + | AddrOf (Var x, off) -> Ok (x,true, stars_typ (Cil.typeOfLval (Var x,off))) + | e -> + begin + match delta_ptr e with + | None -> + (match stars_exp e with + | None -> Any + | Some (x,ty,n) -> + let stars = stars_typ ty in + if n < stars + then Ok (x,false,n) else + (if stars = n then Any else Ko (x,false,n))) + | Some (x,n) -> Ok (x,false,n) + end + +let by_pointer_reference_pattern_term = function + | TLval(TVar lvar, off) + | Tat ({term_node = TLval(TVar lvar, off) },_)-> + let t = Cil.typeOfTermLval (TVar lvar,off) in + if Logic_utils.isLogicPointerType t then + Ok (lvar,false,stars_lv_typ t) + else Any + | TAddrOf(TVar lvar, off) + | Tat ({term_node = TAddrOf(TVar lvar, off) },_)-> + Ok (lvar,true, stars_lv_typ (Cil.typeOfTermLval (TVar lvar,off))) + | Tat({term_node = t},_) | t -> + begin + match delta_ptr_term t with + | None -> + (match stars_term t with + | None -> Any + | Some (x,ty,n) -> + let stars = stars_lv_typ ty in + if n < stars + then Ok (x,false,n) else + (if n = stars then Any else Ko (x,false,n))) + | Some (x,n) -> Ok (x,false,n) + end + + + +(* help called in [by_array_reference_pattern e]) +let help_by_array_reference_pattern e = + match delta_array e with + | None -> + (match bracket_exp e with + | None -> Any + | Some (x,n) -> + if x.vformal then + begin + let dim = brackets_typ x.vtype in + if n < dim + then (Ok (x,false,n)) else + (if n = dim then Any else Ko (x,false,n)) + end + else Ok(x,false,n)) + | Some (x,n) -> Ok (x,false,n) + + + +([by_array_reference_pattern e] returns [Ok (x,b,n)] + if [x] appears as a root in [e] with test of address taken (b] and arity [n]. + + A by array reference pattern is one of the following : + - x+offset (StarOf) ----> Ok(x,true,arity_of (typ(x))); + - x<k>[], k < bracket(typ(x)) ----->Ok(x,false,k); + - &(x+i) + ==+PI ----> Ok(x,true,n) + + else returns: + - [Any] when the pattern is not significant ; + - [Ko] when the pattern is clearly uncompatible with a + by array reference pattern. +*) + + +let by_array_reference_pattern = function + | StartOf (Var x,off) -> Ok (x,true,brackets_typ (Cil.typeOfLval (Var x,off))) + | CastE(ty,{enode = StartOf (Var x,off)}) when Cil.isPointerType ty -> + Ok (x,true,brackets_typ (Cil.typeOfLval (Var x,off))) + | AddrOf (Mem e, _) -> + (match delta_ptr (Cil.stripInfo e).enode with + | None -> Any + | Some (x,n) -> Ok (x,true,n)) + | CastE (t,e) -> + debug "[by_array_reference_pattern] cast case"; + if Cil.isPointerType t then + ( debug "is a pointer type"; + help_by_array_reference_pattern (Cil.stripInfo e).enode) + else + (debug "is NOT a pointer type " ;Any ) + | e -> help_by_array_reference_pattern e + + +let help_array_reference_pattern_term s t = + match delta_array_term t with + | None -> + (match bracket_term t with + | None -> Any + | Some (x,n) -> + if is_lformal x then + begin + debug "%s %a[]<%d>" s !Ast_printer.d_logic_var x n; + let dim = brackets_lv_typ x.lv_type in + if n < dim + then + (debug "%s %a has dimension %d ok!" + s !Ast_printer.d_logic_var x n; + Ok (x,false,n)) + else + ( if dim = n then Any else + (debug "%s %a has dimension %d when need %d!" + s !Ast_printer.d_logic_var x dim n; + Ko (x,false,n))) + end + else Ok(x,false,n) + ) + | Some (x,n) -> + debug "%s %a in delta_array term" s !Ast_printer.d_logic_var x; + Ok (x,false,n) + +let by_array_reference_pattern_term t = + let s = "[by_array_reference_pattern_term]" in + match t with + | TStartOf (TVar lvar,off) + | Tat ({term_node = TStartOf (TVar lvar,off) },_)-> + debug "%s %a " s!Ast_printer.d_logic_var lvar; + Ok(lvar,true,brackets_lv_typ (Cil.typeOfTermLval (TVar lvar,off))) + + |TCastE(ty,{term_node = ( TStartOf (TVar lvar,off) + | Tat ({term_node = TStartOf (TVar lvar,off) },_))}) when + Cil.isPointerType ty -> + debug "%s %a " s!Ast_printer.d_logic_var lvar; + Ok (lvar,true,brackets_lv_typ(Cil.typeOfTermLval (TVar lvar,off))) + + | TAddrOf (TMem t, _) + | Tat ({term_node = TAddrOf (TMem t, _) },_) -> + (match delta_ptr_term t.term_node with + | None -> Any + | Some (x,n) -> + debug "%s %a in delta_ptr term" s !Ast_printer.d_logic_var x; + Ok (x,true,n)) + | Tat({term_node = t},_)-> help_array_reference_pattern_term s t + | TCastE(ty,{term_node = t}) when (Cil.isPointerType ty)-> + help_array_reference_pattern_term s t + | t ->help_array_reference_pattern_term s t + + + + + +(********************************************************************) +(* Collection of potential Chain of by reference calls *) +(********************************************************************) + +(* [collect_calls_occurences (eargs,sgn)] visits a list of arguments and + a signature and collects each call of thus cases: + - [x<n>] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a by pointer reference parameter. + Then, the [chain_call] of [x] is updated in the [ByPReference] table + with the call site [(n,p)]. + + - [x<n>[]] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a by array reference parameter. + Then, the [chain_call] of [x] is updated in the [ByAReference] table + with the call site [(n,p)]. + + - [x<n>] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a none formal. + Then, the [chain_call] of [x] is updated in the [ArgPReference] table + with the call site [(n,p)]. + + - [x<n>[]] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a none formal. + Then, the [chain_call] of [x] is updated in the [ByAReference] table + with the call site [(n,p)]. + + - in all other case, nothing is done and the collection progress + in the tail of both lists. +) + +( Table of by pointer reference argument ) +module ArgPReference = + State_builder.Hashtbl + (VarType.Hashtbl) + (Datatype.Pair (Datatype.Int) (ChainCalls)) + (struct let name = "WP: argument by pointer reference not formal" + let dependencies = [Ast.self] + let kind = `Internal + let size = 47 + end) + +(Table of by array reference argument ) +module ArgAReference = + State_builder.Hashtbl + (VarType.Hashtbl) + (Datatype.Pair (Datatype.Int) (ChainCalls)) + (struct let name = "WP: argument by array reference not formal" + let dependencies = [Ast.self] + let kind = `Internal + let size = 47 + end) + + + +( [add_ptr_reference_arg x n] tries to adds [x] of arity [n] in the + table of by pointer reference argument. + + -If [x] is in AnyVar table, then [x] can't been added to this table. + + -If [x] is already registered in by pointer reference argument, the + already recorded arity has to be [n] else [x] is removed from this + table and adds to the AnyVar table. + + - If [x] is not registered in the by pointer reference table: + [x] is in the by array reference argument then [x] is removed + from this table and adds to the any var table. + else [x] is registered in the by pointer reference argument with the + arity [n] and the empty chain call. +) +let add_ptr_reference_arg x n = + oracle "[ArgPRef] try + %a" pp_var_type x; + if AnyVar.mem x then + (oracle "[ArgPRef] %a AnyVar"pp_var_type x;()) + else + begin + try + if not (fst (ArgPReference.find x) = n) then + (oracle "[ArgPRef] remove %a : ko arity ->+AnyVar" + pp_var_type x; + ArgPReference.remove x; AnyVar.replace x ()) + else + (oracle "[ArgPRef] %a already" pp_var_type x;()) + with Not_found -> + (if ArgAReference.mem x then + (oracle "[ArgPRef] %a ArgARef : remove -> + AnyVar" + pp_var_type x; + ArgAReference.remove x; AnyVar.add x ()) + else + (oracle "[ArgPRef] + %a"pp_var_type x; + ArgPReference.add x (n,[]))) + end + +let remove_ptr_reference_arg x = + oracle "[ArgPRef] remove %a" pp_var_type x; + if ArgPReference.mem x then + (oracle "[ArgPRef] remove %a of ArgPRef" pp_var_type x; + ArgPReference.remove x); + oracle "[ArgPRef] + %a AnyVar" pp_var_type x ; + AnyVar.replace x () + +( [add_array_reference_arg x n] tries to add [x] with arity [n] in the table + of by array reference arguments. + - If [x] is in any var table, [x] can't been added to this table. + + - If [x] already registered in the by array reference argument; then + the already recorded arity has to been [n] otherwise + [n] is not the correct arity, [x] is removed from this table + and adds to the any var table + [n] is the correct arity, nothing has to be done + - If [x] is not yet in the table of by array reference argument: + [x] is in the table of by pointer reference argument. [x] is removed + form this table and adds to the any var table + [x] has not yet been registered, [x] is registered with the + arity [n] and the empty chaincalls in the table of by array reference + argument. +) +let add_array_reference_arg x n = + oracle "[ArgARef] try + %a" pp_var_type x; + if AnyVar.mem x then + (oracle "[ArgARef] %a AnyVar"pp_var_type x;()) + else + begin + try + if not (fst (ArgAReference.find x) = n) then + (oracle "[ArgARef] remove %a : ko arity ->+AnyVar" + pp_var_type x; + ArgAReference.remove x; AnyVar.replace x ()) + else + (oracle "[ArgARef] %a already" pp_var_type x;()) + with Not_found -> + (if ArgPReference.mem x then + (oracle "[ArgARef] %a ArgPRef : remove -> + AnyVar" + pp_var_type x; + ArgPReference.remove x; AnyVar.add x ()) + else + (oracle "[ArgARef] + %a"pp_var_type x; + ArgAReference.add x (n,[]))) + end + +let remove_array_reference_arg x = + oracle "[ArgARef] remove %a" pp_var_type x; + if ArgAReference.mem x then + (oracle "[ArgARef] remove %a of ArgARef" pp_var_type x; + ArgAReference.remove x); + oracle "[ArgARef] + %a AnyVar" pp_var_type x ; + AnyVar.replace x () + + +( [collect_calls_rec (eargs,sgn)] visits a list of arguments and + a signature and collects each call of thus cases: + - [x<n>] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a by pointer reference parameter. + Then, the [chain_call] of [x] is updated in the [ByPReference] table + with the call site [(n,p)]. + - [x<n>[]] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a by array reference parameter. + Then, the [chain_call] of [x] is updated in the [ByAReference] table + with the call site [(n,p)]. + - [x<n>] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a none formal. + Then, the [chain_call] of [x] is updated in the [ArgPReference] table + with the call site [(n,p)]. + - [x<n>[]] in [eargs] associates to the parameter [p] + into the signature [sgn] when [x] is a none formal. + Then, the [chain_call] of [x] is updated in the [ByAReference] table + with the call site [(n,p)]. + - in all other case, nothing is done and the collection progress + in the tail of both lists. + + Implements 2p) 2a) and computation of other kind of variables passed + by reference. +) + +([collect_formal_array_call s x n b p] tries to collect in bellow function + characterized by [s] for debugging the by array reference call [(n,(b,p))] + in the chaincall of the by array reference parameter [x] with: + arity [n] with test of address taken [b] on prameter type [p] with + the effective argument containing the variable [x]. + -If [x] already in the table of by array reference parameter: + * [n] is convenient with the registered arity of [x] then + adds the call to the chain call of [x] + * else [x] is removed from the table of by array reference parameters + -If [x] is not yet registered in the table of by array reference parameters, + tries to add [x] in this table: + * if ok then computes the arity of [x], [arr]. + a) if [n] is convenient for [arr] then add [x] to the table of + by array reference parameter with arity [arr] and the call. + b) else nothing has to be done + ) +let collect_formal_array_call s x n b p = + try + let (arr,calls) = ByAReference.find x in + oracle "%s %a ByARef" s pp_var_type x; + if n <= arr then + ( oracle "%s %a + call(%a,%d,%s)" s pp_var_type x + pp_var_type p n (string_addr b); + ByAReference.replace x (arr,((n,(b, p))::calls))) + else + ( oracle "%s %a remove %d used %d" s pp_var_type x arr n; + remove_array_reference_param x) + with Not_found -> + oracle "%s %a not yet ByARef" s pp_var_type x; + let arr = brackets_and_stars_var_type_typ x in + add_array_reference_param x arr; + try let (_,calls) = ByAReference.find x in + ByAReference.replace x (arr,(n,(b,p))::calls) + with Not_found -> () + + +( as collect_arg_array_call for by pointer reference call of argument.) +let collect_arg_ptr_call s x n b p = + if AnyVar.mem x then + (oracle "%s %a AnyVar" s pp_var_type x ;()) + else + try + let (arr,calls) = ArgPReference.find x in + oracle "%s %a ArfPRef" s pp_var_type x; + if n <= arr then + (oracle "%s %a + call(%a,%d,%s)" s pp_var_type x + pp_var_type p n (string_addr b); + ArgPReference.replace x (arr,((n,(b,p))::calls))) + else + (oracle "%s %a remove %d used %d" s pp_var_type x arr n; + remove_ptr_reference_arg x) + with Not_found -> + oracle "%s %a not yet in ArgPref" s pp_var_type x; + let arr = stars_var_type_typ x in add_ptr_reference_arg x arr; + if ArgPReference.mem x then + (if n <= arr then + (oracle"%s %a + call(%a,%d,%s)" + s pp_var_type x pp_var_type p n (string_addr b); + ArgPReference.replace x (arr,[n,(b,p)])) + else ()) + + +( [collect_arg_array_call s x n b p] tries to collect, in the bellow function + characterized by [s] for debugging, the calls [(n,(b,p))] in the chain call + of the by array reference argument [x]. + -If [x] is any var, nothing has to be done. + -If [x] is already registered in the table of by array reference argument, + according to the convenient of [n] to the registered arity of [x], + the calls is added to the chaincall of (x] or [x] is removed from this + table. + -If (x] is not yet registered, the arity of [x] is computed [arr] and + and tries to add [(x,arr)] in the table of by array reference argument. + If the add succeed adds the call else nothing has to be done +) +let collect_arg_array_call s x n b p = + if AnyVar.mem x then + (oracle "%s %a AnyVar" s pp_var_type x ;()) + else + try + let (arr,calls) = ArgAReference.find x in + oracle "%s %a ArfARef" s pp_var_type x; + if n <= arr then + (oracle "%s %a + call(%a,%d,%s)" s pp_var_type x + pp_var_type p n (string_addr b); + ArgAReference.replace x (arr,((n,(b,p))::calls))) + else + (oracle "%s %a remove %d used %d" s pp_var_type x arr n; + remove_array_reference_arg x) + with Not_found -> + oracle "%s %a not yet in ArgAref" s pp_var_type x; + oracle "%s %a try to collect with %d" + s pp_var_type x n; + if isVarTypePointerType x then collect_arg_ptr_call s x n b p + else + (if n <> 0 then + (oracle"%s %a + call(%a,%d,%s)" + s pp_var_type x pp_var_type p n (string_addr b); + add_array_reference_arg x n; + try let (n,calls) = ArgAReference.find x in + ArgAReference.replace x (n,(n,(b,p))::calls) + with Not_found -> ()) + else ()) + +( as collect_formal_array_call for by pointer reference parameters. + Note that is [px] not yet in the table of by pointer reference parameters + then if [px] is in the table of by array reference parameters then + tries to register this call as a formal array call -> + [collect_formal_array_call] In fact, the patterns of by array reference calls + contains the patterns of by pointer reference calls. +) +let collect_formal_ptr_call s px n b p = + try + let (arr,calls) = ByPReference.find px in + oracle "%s %a ByPRef" s pp_var_type px; + if n <= arr then + ( oracle "%s %a + call(%a,%d,%s)" s pp_var_type px + pp_var_type p n (string_addr b); + ByPReference.replace px (arr,((n,(b,p))::calls))) + else + ( oracle "%s %a remove %d used %d" s pp_var_type px arr n; + remove_ptr_reference_param px) + with Not_found -> + oracle "%s %a not yet ByPRef" s pp_var_type px; + if ByAReference.mem px then collect_formal_array_call s px n b p + else + begin + let arr = stars_var_type_typ px in add_ptr_reference_param px arr; + if ByPReference.mem px then + (if n <= arr then + ( oracle "%s %a + call(%a,%d,%s)" + s pp_var_type px pp_var_type p n (string_addr b); + ByPReference.replace px (arr,[n,(b,p)]))) + else () + end + + + + +([collect_calls_rec (eargs,fmls)] collects, in a C call assigning the + effective arguments [eargs] to the formal parameter [fmls], + the calls, using preview functions according to the identified argument + patterns for each pair of effective argument [e] and formal parameter + [p]. + ) +let rec collect_calls_rec (eargs,fmls) = + let s = "[collect_calls]" in + match eargs,fmls with + | [],[] -> () + | [], _ | _, [] -> () (TODO: check for variadyc functions ) + | e::args, p::fmls -> + debug "%s no empty list" s; + let e1 = (Cil.stripInfo e).enode in + (match by_array_reference_pattern e1 with + | Ok (x,b,n) -> + let sb =string_addr b in + debug "%s array pattern of %a with %s" s + !Ast_printer.d_var x sb; + let x = Cv x and p = Cv p in + if is_formal_var_type x then + collect_formal_array_call s x n b p + else + collect_arg_array_call s x n b p + + | Ko (x,_,_) -> + debug "%s not array pattern" s; + if x.vformal then + remove_array_reference_param (Cv x) + else ArgAReference.remove (Cv x) + | Any -> + ( match by_pointer_reference_pattern e1 with + | Ok (x,b,n) -> + let sb = string_addr b in + debug "%s ptr pattern of %a with %s and %d" + s !Ast_printer.d_var x sb n; + let x = Cv x and p = Cv p in + if is_formal_var_type x then + collect_formal_ptr_call s x n b p + else collect_arg_ptr_call s x n b p + + | Ko (x,_,_) -> + debug "%s not ptr pattern" s; + if x.vformal then remove_ptr_reference_param (Cv x) + else ArgPReference.remove (Cv x) + + | Any ->() + ) + ); collect_calls_rec (args,fmls) + + +let collect_calls f el = + let kf = Globals.Functions.get f in + let fmls = Kernel_function.get_formals kf in + debug "[collect_calls]"; + collect_calls_rec (el,fmls) + + +let ok_array_term_formal s x n b p = + collect_formal_array_call s x n b p + +let ok_array_term_arg s x n b p = + collect_arg_array_call s x n b p + +let ok_array_term s x n b p = + if is_formal_var_type x then ok_array_term_formal s x n b p + else ok_array_term_arg s x n b p + +let ok_ptr_term_formal s x n b p = + collect_formal_ptr_call s x n b p + +let ok_ptr_term_arg s x n b p = + collect_arg_ptr_call s x n b p + +let ok_pointer_term s x n b p = + if is_formal_var_type x then ok_ptr_term_formal s x n b p + else ok_ptr_term_arg s x n b p + +( as collect_calls_rec on logic application) +let rec collect_apps_rec = function + | [],[] -> () + | [], _ | _, [] -> () (TODO: check correctness for variadyc functions ) + | t::args, p::fmls -> + let s = "collect_app" in + (match by_array_reference_pattern_term t.term_node with + | Ok (x,b,n) -> + debug "(%a,%b,%d) by_array in apps_rec" + !Ast_printer.d_logic_var x b n; + ok_array_term s (var_type_of_lvar x) n b (var_type_of_lvar p ) + | Ko (x,_,_) -> + let x = var_type_of_lvar x in + if is_formal_var_type x + then remove_array_reference_param x + else ArgAReference.remove x + + | Any -> + ( match by_pointer_reference_pattern_term t.term_node with + | Ok (x,b,n) -> + let p = var_type_of_lvar p in + let x = var_type_of_lvar x in + ok_pointer_term s x n b p + | Ko (x,_,_) -> + let x = var_type_of_lvar x in + if is_formal_var_type x + then remove_ptr_reference_param x + else ArgPReference.remove x + | Any ->() + ) + ); collect_apps_rec (args,fmls) + +let collect_apps lf tl = collect_apps_rec (tl,lf.l_profile) + + + +( as collect_apps_rec on logic builtin application + if the argument is a userdef parameter, its information in + LogicParam is updated by the test of addresse taken ) +let rec collect_apps_builtin targs = + let s = "[BuiltinCall]" in + match targs with + | [] -> () + | t::args -> + (match by_array_reference_pattern_term t.term_node with + | Ok (x,b,n) -> + debug "%s %a in array ref position with %s with dim = %d" + s !Ast_printer.d_logic_var x (string_addr b) n; + logic_param_memory_info x; + ok_array_term s (var_type_of_lvar x) n b Prop + | Ko (x,_,_) -> + debug "%s %a is not in a array ref position" + s !Ast_printer.d_logic_var x ; + let x = var_type_of_lvar x in + if is_formal_var_type x + then remove_array_reference_param x + else ArgAReference.remove x + + | Any -> + ( match by_pointer_reference_pattern_term t.term_node with + | Ok (x,b,n) -> + debug "%s %a in ptr ref position with %s with %d " + s !Ast_printer.d_logic_var x (string_addr b) n; + logic_param_memory_info x; + ok_pointer_term s (var_type_of_lvar x) n b Prop + | Ko (x,_,_) -> + debug "%s %a is not in a ptr ref position" + s !Ast_printer.d_logic_var x ; + let x = var_type_of_lvar x in + if is_formal_var_type x + then remove_ptr_reference_param x + else ArgPReference.remove x + | Any -> () + ) + ); collect_apps_builtin args + + +(********************************************************************) +(* Chain of calls collections *) +(********************************************************************) + +let calls_collection_computed = ref false + +(* This visitor inpects all calls,applications and ACSL builtin applications + and then : + - collects [call]s and builds [chaincalls] of each kind of variable; + - redefines the kind of a variable if needed. + Typically when patterns of a same variable are of different kinds + or for a formal when the usage (found in the last visitor) is not + compatible with a pttern (found in this visitor). + +NB: The resolution of an entire [ChainCall] can't been done here because + all [call] has to been inspected before. + +*) + +class calls_collection : Visitor.frama_c_visitor = object + inherit Visitor.frama_c_inplace + + method vinst = function + | Call (_ ,{enode =Lval(Var f,NoOffset)} , el,_) as e-> + debug "[Calls_collection] call %a" !Ast_printer.d_instr e; + collect_calls f el ; SkipChildren + | _ -> DoChildren + + method vterm t = + match t.term_node with + | Tapp (lf,_ , targs) -> + debug "[Calls_collection] app %a" !Ast_printer.d_term t; + collect_apps lf targs ; SkipChildren + | Tblock_length ta -> + debug "[Calls_collection] block_length %a" !Ast_printer.d_term t; + collect_apps_builtin [ta] ; SkipChildren + | _ -> DoChildren + + method vpredicate = function + | Papp (lf, _, targs) -> collect_apps lf targs ; SkipChildren + | Pvalid t | Pvalid_index(t,_) | Pvalid_range(t,_,_) + | Pinitialized t | Pfresh t -> + debug "[Calls_collection] predicate app on %a" !Ast_printer.d_term t; + collect_apps_builtin [t] ; SkipChildren + | Pseparated lt -> collect_apps_builtin lt ; SkipChildren + | _ -> DoChildren + +end + +let compute_calls_collection () = + debug + "[Calls Collection] collectinfg potential by reference calls"; + debug + "[Calls Collection] computing parameters usage first"; + compute_parameters_usage (); + if not !calls_collection_computed then + (Visitor.visitFramacFile (new calls_collection)(Ast.get()); + calls_collection_computed := true) + + + + +(********************************************************************) +(* Chain of calls Resolution *) +(********************************************************************) + + +(* + B - Chain of Calls Resolutions + The second part of the by-reference-parameters + identification, is the verification of the [ChainCalls] + for each formal parameter occured in ByPReference + or ByAReference table. + Concerning the argument by-reference, chain of calls has to be + resolved too. During this resolution, the addrtaken table is + updated : address taken in real by-reference call are + subtracted. + + The resolution of the [ChainCall] of formal parameters have to occur + before de resolution the [ChainCall]of other variable. + +) + + +( Chain of call resolution of the table of by pointer reference parameters. + A convenient [call] for a by pointer reference parameter [x] with + arity [n] is : + -a builtin application [(k,(b,Prop))], k <= [n] + -an application or call [(k,(b,p))], k <= n and [p] is a + by pointer reference parameter. + + For each convenient [call], if the test of address taken is true, then + the [minus] information of [x] in the address taken table is incremented. + + A [ChainCalls] is resolved when all is [call]s has been inspected. + If all [call]s of the [ChainCalls] [calls] are convenient, + [x] stays in by pointer reference parameter with arity [n]. + Otherwise, [x] is moved from the by pointer reference parameter + table to the by value parameter table. + + NB: For a call [(k,(b,p))], [p] can not yet occur in + the by pointer reference paramter table, then [p] has first to be + add in this table and its [ChainCalls] has to been resolved before + the resolution of this call. + +) +let rec by_ptr_reference x n calls = + let s = "[by_ptr_reference]" in + debug "%s %a of arity %d" s pp_var_type x n; + match calls with + | [] -> + debug "%s %a: ok " s pp_var_type x; + oracle "%s %a ByPref" s pp_var_type x; + ByPReference.replace x (n,[]) + | (k,(b,Prop))::m -> + let sb = string_addr b in + debug "%s %a: (builtin,%d,%s)" s pp_var_type x k sb; + if k <= n then + (debug "%s arity of call ok" s; decr_addr_taken_bool x b; + by_ptr_reference x n m) + else + (debug "%s arity of call too big" s; remove_ptr_reference_param x) + | (k,(b,p))::m -> + let bv = ByValue.mem p in let ba = ByAReference.mem p in + let c = k > n in let sb = string_addr b in + if c || bv || ba then + (debug "%s: KO %a ByValue:%b ; Aref : %b; call arity:%b" + s pp_var_type p bv bv c ; remove_ptr_reference_param x) + else + (debug "%s: OK %a ByValue:%b ; Aref : %b; call ari:%b; with %s" + s pp_var_type p bv ba c sb ; + try (match ByPReference.find p with + | (i,[]) -> + debug "%s %a already resolved ; arity :%d" + s pp_var_type p i; + if k <= i then + (debug"%s arity OK" s; decr_addr_taken_bool x b; + by_ptr_reference x n m) + else + (debug "%s arity KO %a with %d and %a with %d used %d" + s pp_var_type x n pp_var_type p i k; + remove_ptr_reference_param x ) + | (i,lp) -> + debug "%s %a has to be resolved; with %d used %d" + s pp_var_type p i k; + if k <= i then + (by_ptr_reference p i lp; + by_ptr_reference x n ((k,(b,p))::m)) + else remove_ptr_reference_param x + ) + with Not_found -> + debug "%s %a NOT in PRef param" s pp_var_type p; + let i = stars_var_type_typ p in + add_ptr_reference_param p i; + if not (ByPReference.mem p) || ByValue.mem p + then remove_ptr_reference_param x + else by_ptr_reference x n ((k,(b,p))::m)) + + +( Chain of call resolution of the table of by array reference parameters) +let rec by_array_reference x n l = + let s = "[by_array_reference]" in + debug "%s %a of arity %d" s pp_var_type x n; + match l with + | [] -> + oracle "%s %a ByAref" s pp_var_type x; + ByAReference.replace x (n,[]) + | (k,(b,Prop))::m -> + if k <= n then + (decr_addr_taken_bool x b; by_array_reference x n m) + else remove_array_reference_param x + | (k,(b,p))::m -> + if k < n || ByValue.mem p || ByPReference.mem p then + remove_array_reference_param x + else + try (match ByAReference.find p with + | (i,[]) -> + if i <= k then + (decr_addr_taken_bool x b; by_array_reference x n m) + else remove_array_reference_param x + | (i,lp) -> + if i <= k then + (by_array_reference p i lp; + by_array_reference x n ((k,(b,p))::m)) + else remove_array_reference_param x + ) + with Not_found -> + debug "%s %a NOT in ARef param" s pp_var_type p; + let i = brackets_and_stars_var_type_typ p in + add_array_reference_param p i; + if not (ByAReference.mem p) || ByValue.mem p + then remove_array_reference_param x + else by_array_reference x n ((k,(b,p))::m) + +( resolution of chain of call of formal parameters.) +let resolved_call_chain_param () = + ByAReference.iter + (fun var (n,l) -> + debug "[resolve chaincall of param] array -> %a:%a" + pp_var_type var pp_chaincall l; + by_array_reference var n l) ; + ByPReference.iter + (fun var (n,l) -> + debug "[resolve chaincall of param] ptr -> %a:%a" + pp_var_type var pp_chaincall l; + by_ptr_reference var n l) + +( Chain of call resolution of the table of by pointer reference argument) +let rec ptr_reference x n calls = + let s = "[ptr_reference arg]" in + match calls with + | [] -> + debug "%s %a: arity %d ok" s pp_var_type x n; + oracle "%s %a ArgPref" s pp_var_type x; + ArgPReference.replace x (n,[]) + | (k,(b,Prop))::m -> + let sb = string_addr b in + debug "%s (%a,%d) used builtin %d and %s" s pp_var_type x n k sb; + if k <= n then + ( debug "%s builtin arity OK" s; decr_addr_taken_bool x b ; + ptr_reference x n m) + else + (debug "%s builtin arity KO" s; remove_ptr_reference_arg x) + | (k,(b,p))::m -> + let sb = string_addr b in + debug "%s (%a %d) ; used as (%a,%d) and %s" + s pp_var_type x n pp_var_type p k sb; + if k > n then + (debug "%s %a:arity KO " s pp_var_type p; + remove_ptr_reference_arg x) + else + try (match ByPReference.find p with + | (i,[]) -> + debug "%s %a is byPref resolved" s pp_var_type p; + if k <= i then + ( debug "%s arity OK" s; decr_addr_taken_bool x b; + ptr_reference x n m) + else (debug "%s arity KO" s; remove_ptr_reference_arg x) + | (i,lp) -> ( can't happen ) + debug "%s %a is byPref NOT resolved"s pp_var_type p; + if k <= i then + ( debug "%s arity OK"s ;by_ptr_reference p i lp; + debug "%s resolution of %a" s pp_var_type p; + ptr_reference x n ((k,(b,p))::m)) + else + (debug "%s arity KO" s; remove_ptr_reference_arg x ) + ) + with Not_found -> ( can't happen ) + debug "%s %a NOT ByPRef" s pp_var_type p; + let i = stars_var_type_typ p in + add_ptr_reference_param p i; + if not (ByPReference.mem p) || ByValue.mem p + then remove_ptr_reference_arg x + else ptr_reference x n ((k,(b,p))::m) + + +( Chain of call resolution of the table of by array reference argument) +let rec array_reference x n calls = + let s = "[array_reference arg]" in + match calls with + | [] -> + debug "%s %a: arity %d ok" s pp_var_type x n; + oracle "%s %a ArgAref" s pp_var_type x; + ArgAReference.replace x (n,[]) + | (k,(b,Prop))::m -> + if k <= n then + (decr_addr_taken_bool x b; array_reference x n m) + else remove_array_reference_arg x + | (k,(b,p))::m -> + if k > n then ArgAReference.remove x + else + ( + if ByPReference.mem p then + begin + try (match ByPReference.find p with + | (i,[]) -> + debug "%s %a is byPref resolved" s pp_var_type p; + if k <= i then + ( debug "%s arity OK" s; decr_addr_taken_bool x b; + array_reference x n m) + else + (debug "%s arity KO" s; + remove_array_reference_arg x) + | (i,lp) -> ( can't happen ) + debug "%s %a is byPref NOT resolved"s pp_var_type p; + if k <= i then + ( debug "%s arity OK"s ;by_ptr_reference p i lp; + debug "%s resolution of %a" s pp_var_type p; + array_reference x n ((k,(b,p))::m)) + else + (debug "%s arity KO" s; + remove_ptr_reference_arg x ) + ) + with Not_found -> remove_array_reference_arg x + end + else + begin + try (match ByAReference.find p with + | (_,[]) -> + decr_addr_taken_bool x b; array_reference x n m + | (i,lp) -> ( can't happen ) + by_array_reference p i lp; + array_reference x n ((k,(b,p))::m) + ) + with Not_found -> ( can't happen ) + debug "%s %a NOT ByARef" s pp_var_type p; + let i = brackets_and_stars_var_type_typ p in + add_array_reference_param p i; + if not (ByAReference.mem p) || ByValue.mem p + then remove_array_reference_arg x + else array_reference x n ((k,(b,p))::m) + end + ) + + +( resolution of chain of call of arguments.*) +let resolved_call_chain_arg () = + ArgAReference.iter + (fun var (n,l) -> + debug "[resolve chaincall of arg] array -> %a:%a" + pp_var_type var pp_chaincall l; + array_reference var n l) ; + ArgPReference.iter + (fun var (n,l) -> + debug "[resolve chaincall of arg] ptr -> %a:%a" + pp_var_type var pp_chaincall l; + ptr_reference var n l) + + +(********************************************************************) +(* Address Taken Resolution *) +(********************************************************************) + +(* [resolve_addr_taken ()] iterates on Address Taken table. + For each variable [var] : + - if the occurences of address taken out of by reference call [m] + is strictly more than the occurences in by reference call [r] then + [var] stays in the address taken table and it is removes from the + by reference table. + - if [var] address taken occurs more or as much in by reference calls + [r] than in other case [m] then [var] is remove from the address taken + table.*) + + let resolve_addr_taken () = + let remove_from_refs var = + if is_formal_var_type var then + (remove_ptr_reference_param var; + remove_array_reference_param var) + else + (ArgPReference.remove var; ArgAReference.remove var) + in + let s = "[resolves addr taken]" in + AddrTaken.iter + (fun var (m,r) -> + debug "%s %a +:%d -:%d" s pp_var_type var m r ; + if m > r then + (debug "%s %a: addr taken %d et %d" s pp_var_type var m r; + oracle"%s %a: stays addrtaken"s pp_var_type var; + remove_from_refs var) + else + (debug "%s %a: not addr taken %d et %d" s pp_var_type var m r; + oracle"%s %a: remove addrtaken"s pp_var_type var; + AddrTaken.remove var)) + + + + +(********************************************************************) +(* Adding Separated hypothesis *) +(********************************************************************) + +(* The optimization of by reference calls supposing a quiet important + number of hypothesis about separation between variables. + One of this kind of separation hypothesis concerns + the separation between by pointer reference parameters of a same + signature and all their dereferenced pointers. In this case , + we add the pre-condition to the contract of the function. + Concerning other kind of separation hypothesis, we emit a warning.) + + + ( Creates the l-value lv ) + let deref loc (t:term) : term = + let typ = match t.term_type with + | Ctype (TPtr (typ,_)) -> Ctype typ + | _ -> Wp_parameters.fatal "[deref] on a pure logic type" + in + Logic_const.term ~loc (TLval (TMem t,TNoOffset)) typ + + type formal_kind = + | Formal_Value + | Formal_Ref of int + | Formal_Array of int + + let kind_of_formal x = + try + let (n,_calls) = ByPReference.find (Cv x) in + if Cil.isPointerType x.vtype then + Formal_Ref n + else + Formal_Value + with Not_found -> + try + let (n,_calls) = ByAReference.find (Cv x) in + Formal_Array n + with Not_found -> + Formal_Value + + let rec collect_sepstars loc n (t:term) (sep_terms:term list) = + let sep_terms = t :: sep_terms in + if n=1 then sep_terms else + let tstar = deref loc t in + collect_sepstars loc (pred n) tstar sep_terms + + + let pp_formals fmt = function + | [] -> () + | x::xs -> + Format.fprintf fmt "'%s'" x.vname (* user info *) ; + List.iter (fun x -> Format.fprintf fmt ",@ '%s'" x.vname) xs + + let rec collect_refparams kf loc arr_vars ref_vars sep_terms = function + | x::xs -> + begin + match kind_of_formal x with + | Formal_Value -> + collect_refparams kf loc arr_vars ref_vars sep_terms xs + | Formal_Array _ -> + collect_refparams kf loc (x::arr_vars) ref_vars sep_terms xs + | Formal_Ref n -> + let t = Logic_const.tvar ~loc (Cil.cvar_to_lvar x) in + let sep_terms = collect_sepstars loc n t sep_terms in + collect_refparams kf loc arr_vars (x::ref_vars) sep_terms xs + end + | [] -> + begin + match List.rev arr_vars , List.rev ref_vars with + | [] , _ -> () + | [_] , [] -> () + | xs , [] -> + Wp_parameters.warning + "For function %s,@ array reference parameters %a@ must be disjoint at call site" + (Kernel_function.get_name kf) pp_formals xs + | xs , ys -> + Wp_parameters.warning + "For function %s, reference parameters@ %a and %a@ must be disjoint at call site" + (Kernel_function.get_name kf) pp_formals xs pp_formals ys + end ; + match sep_terms with + | [] | [_] -> None + | ts -> Some(Logic_const.new_predicate (Logic_const.pseparated ts)) + + let add_requires hyp bhvs = + debug "[add_requires] size of bhs :%d" (List.length bhvs); + try + List.iter + (fun b -> + if Cil.is_default_behavior b then begin + b.b_requires <- hyp :: b.b_requires; + raise Exit + end) + bhvs + with Exit -> + () + + let kernel_functions_separation_hyps () = + debug "[kf separation hyps]"; + Globals.Functions.iter + (fun kf -> + debug "[kf separation hyps] %s" (Kernel_function.get_name kf); + let formals = Kernel_function.get_formals kf in + let loc = Kernel_function.get_location kf in + match collect_refparams kf loc [] [] [] formals with + | Some hyp -> + debug "[kf separation hyps] case hyp:%a" + Cil.d_identified_predicate hyp; + Kernel_function.set_spec + kf (fun fspec -> + add_requires hyp fspec.Cil_types.spec_behavior; + fspec ); + | None -> + debug "[kf separation hyps] case None"; + ()) + +(********************************************************************) +(* Variable Anaylisis Computation *) +(********************************************************************) + +(* + If both optimization are required : + + Computation of the variable analysis; calls all visitors and resolution + in the good order, which is the order of their definitions in this file: + - Computation of address taken, collection of logic formal parameters, + preserved universally and existentially bound variables from the + optimization ; + - Identification of usages of formal parameters without + inspecting calls, application and ACSL builtin application + to dispatch them into formal parameters tables. + - Collection of calls according to the pattern of the effective + arguments and, then, updating the [ChainCalls] of the variables tables. + Collecting the occurences of address taken into a by reference pattern + and updating the AddressTaken table. + - Resolution of [ChainCalls], first in formal parameters tables, + secondly in other kind of variables tables. + - Resolution of address taken table. + + If only logicVar is required : + - Computation of addresse taken table. + +) + + +type case = + | All ( both optimizations are required) + | Nothing ( none of the optimization are required ) + | Half ( only logic var is required) + + +( Discrimination of the case of the analysis ) +let case_of_optimization logicvar refvar = + if not logicvar then (if refvar then All else Nothing) + else (if refvar then All else Half) + +let not_half_computed () = + not (AddrTaken.is_computed()) || not (LogicParam.is_computed()) + +let not_param_computed () = + not (ByValue.is_computed()) || + not (ByPReference.is_computed()) || + not (ByAReference.is_computed()) + +let not_arg_computed() = + not (ArgPReference.is_computed()) || not (ArgAReference.is_computed()) + +let not_computed () = + not_half_computed () && not_param_computed () && not_arg_computed () + + +let compute () = + match case_of_optimization + (Wp_parameters.LogicVar.get ()) (Wp_parameters.RefVar.get()) with + | Nothing -> () + | Half -> + if not_half_computed() then + (debug + "[COMPUTE] DO address taken table computing"; + compute_logic_params ()) + else () + | All -> + if not_computed () then + begin + debug "[COMPUTE] DO all table computation"; + compute_calls_collection (); + debug "[COMPUTE] DONE all table computation"; + debug "[COMPUTE] DO resolution of formals calls"; + resolved_call_chain_param (); + debug + "[COMPUTE] DONE resolution of formals calls"; + debug + "[COMPUTE] DO resolution of arguments chain calls"; + resolved_call_chain_arg (); + debug + "[COMPUTE] DONE resolution of arguments chain calls"; + debug + "[COMPUTE] resolved address taken equation"; + resolve_addr_taken () + end + else () + +let dispatch_var var = + match case_of_optimization + (Wp_parameters.LogicVar.get ()) (Wp_parameters.RefVar.get()) with + | Nothing -> Cvar + | Half -> + compute(); + if AddrTaken.mem var then Cvar else Fvar + | All -> + compute(); + if is_formal_var_type var then + begin + if ByValue.mem var then + if AddrTaken.mem var then Cvar else Fvar + else + ( try let (n,_) = ByPReference.find var in PRpar n + with Not_found -> + (try let (n,_) = ByAReference.find var in ARpar n + with Not_found -> ( impossible case ) Cvar )) + end + else + begin + if AddrTaken.mem var then Cvar + else + (if ArgAReference.mem var then ARarg + else (if ArgPReference.mem var + then PRarg else Fvar)) + end + +let dispatch_cvar vinfo = dispatch_var (Cv vinfo) +let dispatch_lvar lv = dispatch_var (Lv lv) + +let is_user_formal_in_builtin lv = + try LogicParam.find lv with Not_found -> false + +let is_memvar case vinfo = + match case with + | Nothing -> true + | Half | All -> compute(); AddrTaken.mem (Cv vinfo) + +let is_ref case vinfo = + match case with + | Nothing -> false + | Half -> false + | All -> + compute(); + let cv = Cv vinfo in + if vinfo.vformal then + (try fst (ByPReference.find cv) = 0 with Not_found -> false) + else + (try fst (ArgPReference.find cv) = 0 with Not_found -> false) + +( let dumped = Cil_datatype.Varinfo.Hashtbl.create 31 ) +( let dump case x = ) +( match case with Nothing | Half -> () | All -> ) +( begin ) +( compute (); ) +( if not (Cil_datatype.Varinfo.Hashtbl.mem dumped x) then ) +( begin ) +( Cil_datatype.Varinfo.Hashtbl.add dumped x () ; ) +( let cv = Cv x in ) +( Format.eprintf "VAR %s" x.vname ; ) +( if AddrTaken.mem cv then Format.eprintf " addr" ; ) +( let pp name find = try Format.eprintf " %s:%d" name (fst (find cv)) with Not_found -> () in ) +( pp "byref" ByPReference.find ; ) +( pp "byarr" ByAReference.find ; ) +( pp "fref" ArgPReference.find ; ) +( pp "farr" ArgAReference.find ; ) +( Format.eprintf "@." ; ) +( end ) +( end ) + +let is_to_scope vinfo = + let case = case_of_optimization + (Wp_parameters.LogicVar.get ()) (Wp_parameters.RefVar.get()) + in + is_ref case vinfo || is_memvar case vinfo + +let precondition_compute () = + if Wp_parameters.RefVar.get () then + begin + compute (); + kernel_functions_separation_hyps () + end + else () + + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/variables_analysis.mli frama-c-20111001+nitrogen+dfsg/src/wp/variables_analysis.mli --- frama-c-20110201+carbon+dfsg/src/wp/variables_analysis.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/variables_analysis.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,90 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( + This analysis performs a classification of the variables of the input + program. The aim of this classification is to optimize the translation + of variables by WP: + 1) optimization of the by-reference call and + 2) functional variables. +) + +( + At the end, the analysis associates an [var_kind] information to each + variables: + 1) [Fvar] functional variable, variable such as its address is never + taken, + + 2) [PRarg] by_pointer_reference argument, variable such as its + address is only taken in by reference calls (one or more), + + 3) [ARarg] by_array_reference argument, variable such as its + address is only taken in by array reference calls (one or more), + + 4) [PRpar n] by_pointer_reference parameter of arity , + variable which is a formal parameter use for a by reference call + and can be invoked in a chain of by reference call such as their + arity are less or equal than n, + + 5) [ARpar n] by_array_reference parameter of arity , + variable which is a formal parameter use for a by array reference + call and can be invoked in a chain of by array reference call + such as their arity are less or equal than n, + + 6) [Cvar] other variable. + +) + +type var_kind = + Fvar | Cvar | PRarg | ARarg | PRpar of int | ARpar of int + + +( [dispatch_cvar v] returns the var_kind associated to the C variable [v] + according the current optimisations activated.*) +val dispatch_cvar: Cil_types.varinfo -> var_kind + +(** [dispatch_lvar v] returns the var_kind associated to the logic variable [v] + according the current optimisations activated.*) +val dispatch_lvar: Cil_types.logic_var -> var_kind + +(** [is_to_scope v] returns true if [v] has to been scoped into the inner + memory model : cvar of ref*) +val is_to_scope : Cil_types.varinfo -> bool + +(** [precondition_compute ()] adds warnings and precondition suitable + to the current optimisations which are activated *) +val precondition_compute : unit -> unit + +(** [brackets_typ typ] returns the numbre of brackets of the type [typ].*) +val brackets_typ : Cil_types.typ -> int + +(** [is_user_formal_in_builtins lv] tests if the address + of the by-reference formal [lv] of user definition is an argument + of (one or more) ACSL builtin predicate(s) or function : + valid and family, separated, block_length, initialized) +val is_user_formal_in_builtin : Cil_types.logic_var -> bool + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpAnnot.ml frama-c-20111001+nitrogen+dfsg/src/wp/wpAnnot.ml --- frama-c-20110201+carbon+dfsg/src/wp/wpAnnot.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpAnnot.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,1525 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +let dkey = "annot" (* debugging key ) +let debug fmt = Wp_parameters.debug ~dkey fmt + +( This file groups functions that extract some annotations + * and associates them with CFG edges. ) + +open Cil_types +open Cil_datatype + +( -------------------------------------------------------------------------- ) +( --- Global Status --- ) +( -------------------------------------------------------------------------- ) + +let rte_find rte_st kf = let (_,_,status,_) = !rte_st () in status kf +let rte_precond_status = rte_find Db.RteGen.get_precond_status +let rte_signedOv_status = rte_find Db.RteGen.get_signedOv_status +let rte_divMod_status = rte_find Db.RteGen.get_divMod_status +let rte_downCast_status = rte_find Db.RteGen.get_downCast_status +let rte_memAccess_status = rte_find Db.RteGen.get_memAccess_status +let rte_unsignedOv_status = rte_find Db.RteGen.get_unsignedOv_status + +let rte_wp = + [ + "valid pointer dereferencing" , rte_memAccess_status , "-rte-mem" ; + "division by zero" , rte_divMod_status , "-rte-div" ; + "signed overflow" , rte_signedOv_status , "-rte-signed" ; + "unsigned overflow" , rte_unsignedOv_status , "-rte-unsigned-ov" ; + ] + +let rte_generated kf = + List.for_all (fun (_,rte,_) -> rte kf) rte_wp + +let missing_rte kf = + List.map + (fun (name,_,_) -> name) + (List.filter (fun (_,rte,_) -> not (rte kf)) rte_wp) + +let compute_rte_for kf = + begin + Dynamic.Parameter.Bool.set "-rte" true ; + List.iter (fun (_,_,opt) -> Dynamic.Parameter.Bool.set opt true) rte_wp ; + !Db.RteGen.annotate_kf kf ; + end + +let ip_complete f = Property.ip_complete_of_spec f Kglobal f.spec + +let ip_disjoint f = Property.ip_disjoint_of_spec f Kglobal f.spec + +( +(* -------------------------------------------------------------------------- ) +( --- Contract for functions --- ) +( -------------------------------------------------------------------------- ) + +let wp_contract = + Emitter.create "WP Function" ~correctness:[] ~tuning:[] + +let wp_external = + Emitter.create "WP External Function" ~correctness:[] ~tuning:[] + +let ip_contract f = + let ip_rte = + if not (rte_generated f) then + Wp_parameters.warning ~current:false ~once:true + "Missing RTE guards" ; + [ (TODO: these dependencies should be put on the emitter at Wpo level ) ] + in + ip_complete f @ ip_disjoint f @ ip_rte + +let ip_external f = + ip_complete f @ ip_disjoint f + +module FunctionContracts = Wprop.Indexed2(Kernel_function)(Datatype.String) + (struct + let name = "WP Function Contracts" + type key = kernel_function string + let size = 81 + let kind = `Correctness + let dependencies = [ Kernel_function.self ] + let property (kf,model) = + let name = Printf.sprintf + "Function '%s' is consistent with %s" + (Kernel_function.get_name kf) model + in + let ip = Property.ip_other name (Some kf) Kglobal in + match kf.fundec with + | Definition _ -> + Wprop.Proxy( ip , wp_contract , ip_contract kf ) + | Declaration _ -> + Wprop.Proxy( ip , wp_external , ip_external kf ) + end) +) + +( -------------------------------------------------------------------------- ) +( --- Local Preconditions for functions --- ) +( -------------------------------------------------------------------------- ) + +let wp_preconditions = + Emitter.create "WP Call Preconditions" ~correctness:[] ~tuning:[] + +module PreCondAt = Wprop.Indexed2(Property)(Cil_datatype.Stmt) + (struct + let name = "WP Called Preconditions" + type key = Property.t stmt + let size = 81 + let kind = `Correctness + let dependencies = [ Kernel_function.self ] + let property (pid,stmt) = + let kf = Kernel_function.find_englobing_kf stmt in + let name = Pretty_utils.to_string (Description.pp_localized ~kf:`Always ~ki:false) pid in + Wprop.Later (Property.ip_other name (Some kf) (Kstmt stmt)) + end) + +module PreCondProxyGenerated = + State_builder.Hashtbl(Property.Hashtbl)(Datatype.Unit) + (struct + let name = "WP Call Preconditions Generated" + let dependencies = [Ast.self] + let kind = `Internal + let size = 97 + end) + +let pre_cond_id = function + | Property.IPCodeAnnot(_,_,p) -> p.annot_id + | Property.IPPredicate(_,_,_,p) -> p.ip_id + | property -> + Wp_parameters.fatal "No precondition id for @[%a@]" Property.pretty property + +let setup_precondition_proxy called_kf precondition = + if not (PreCondProxyGenerated.mem precondition) then + begin + let called_preconditions = + List.map + (fun (_,stmt) -> PreCondAt.property precondition stmt) + (Kernel_function.find_syntactic_callsites called_kf) + in + Property_status.emit + wp_preconditions ~hyps:called_preconditions precondition + Property_status.True ; + PreCondProxyGenerated.add precondition () + end + +(* Properties for kf-preconditions at call-site stmt, IF CREATED only ) +let lookup_called_preconditions_at kf stmt = + let spec = Kernel_function.get_spec kf in + List.fold_left + (fun properties bhv -> + List.fold_left + (fun properties precond -> + let pid_spec = Property.ip_of_requires kf Kglobal bhv precond in + if PreCondAt.mem pid_spec stmt then + let pid_call = PreCondAt.property pid_spec stmt in + pid_call :: properties + else + properties + ) properties bhv.b_requires + ) [] spec.spec_behavior + +( Properties for kf-preconditions at call-site stmt ) +let get_called_preconditions_at kf stmt = + let spec = Kernel_function.get_spec kf in + List.fold_left + (fun properties bhv -> + List.fold_left + (fun properties precond -> + let pid_spec = Property.ip_of_requires kf Kglobal bhv precond in + let pid_call = PreCondAt.property pid_spec stmt in + pid_call :: properties + ) properties bhv.b_requires + ) [] spec.spec_behavior + +( Properties for kf-conditions of termination-kind 'tkind' *) +let get_called_postconds (tkind:termination_kind) kf = + let spec = Kernel_function.get_spec kf in + List.fold_left + (fun properties bhv -> + List.fold_left + (fun properties postcond -> + if tkind = fst postcond then + let pid_spec = Property.ip_of_ensures kf Kglobal bhv postcond in + pid_spec :: properties + else properties + ) properties bhv.b_post_cond + ) [] spec.spec_behavior + +let get_called_post_conditions = get_called_postconds Cil_types.Normal +let get_called_exit_conditions = get_called_postconds Cil_types.Exits + +(** Properties for assigns of kf ) +let get_called_assigns kf = + let spec = Kernel_function.get_spec kf in + List.fold_left + (fun properties bhv -> + if Cil.is_default_behavior bhv then + match Property.ip_assigns_of_behavior kf Kglobal bhv with + | None -> properties + | Some ip -> ip :: properties + else properties + ) [] spec.spec_behavior + +( -------------------------------------------------------------------------- ) +( --- Status of Unreachable Annotations --- ) +( -------------------------------------------------------------------------- ) + +let wp_unreachable = + Emitter.create + "Unreachable Annotations" + ~correctness:[] ( TBC ) + ~tuning:[] ( TBC ) + +let set_unreachable pid = + debug + "unreachable annotation %a@." WpPropId.pp_id_name pid; + Property_status.emit + wp_unreachable ~hyps:[] (WpPropId.property_of_id pid) Property_status.True + +(----------------------------------------------------------------------------) +( Proofs ) +(----------------------------------------------------------------------------) + +type proof = { + target : Property.t ; + proved : proofpart array ; + mutable dependencies : Property.Set.t ; +} and proofpart = + | Noproof + | Complete + | Parts of Bitvector.t + +let target p = p.target +let dependencies p = Property.Set.elements (Property.Set.remove p.target p.dependencies) + +let create_proof p = + let n = WpPropId.subproofs p in + { + target = WpPropId.property_of_id p ; + proved = Array.create n Noproof ; + dependencies = Property.Set.empty ; + } + +let add_proof pf p hs = + begin + if not (Property.equal (WpPropId.property_of_id p) pf.target) + then Wp_parameters.fatal "Partial proof inconsistency" ; + List.iter + (fun iph -> + if not (WpPropId.is_requires iph) then + pf.dependencies <- Property.Set.add iph pf.dependencies + ) hs ; + let k = WpPropId.subproof_idx p in + match WpPropId.parts_of_id p with + | None -> pf.proved.(k) <- Complete + | Some(p,n) -> + match pf.proved.(k) with + | Complete -> () + | Noproof -> + let bv = Bitvector.create n in + Bitvector.set_range bv 0 (p-1) ; + Bitvector.set_range bv (p+1) (n-1) ; + pf.proved.(k) <- Parts bv + | Parts bv -> + Bitvector.clear bv p ; + if Bitvector.is_empty bv + then pf.proved.(k) <- Complete + end + +let is_composed pf = + Array.length pf.proved > 1 + +let is_proved pf = + try Array.iter (fun r -> if r<>Complete then raise Exit) pf.proved ; true + with Exit -> false + +( -------------------------------------------------------------------------- ) +( --- PID for Functions --- ) +( -------------------------------------------------------------------------- ) + +let mk_call_pre_id called_kf bhv s_call called_pre = + ( TODOclean : quite dirty here ! ) + let id = WpPropId.mk_pre_id called_kf Kglobal bhv called_pre in + let called_pre = WpPropId.property_of_id id in + setup_precondition_proxy called_kf called_pre ; + let called_pre_p = PreCondAt.property called_pre s_call in + WpPropId.mk_call_pre_id called_kf s_call called_pre called_pre_p + +( -------------------------------------------------------------------------- ) +( --- Prop Splitter --- ) +( -------------------------------------------------------------------------- ) + +( prop-id splitter ) + +let split job pid goals = + let n = Bag.length goals in + if n <= 1 then Bag.iter (job pid) goals else + let k = ref 0 in + Bag.iter + (fun g -> + let pid_k = WpPropId.mk_part pid (!k,n) in + incr k ; job pid_k g) + goals + +(----------------------------------------------------------------------------) +( Strategy and annotations ) +(----------------------------------------------------------------------------) + +( This is to code what kind of properties we want to process. ) +type asked_assigns = NoAssigns | OnlyAssigns | WithAssigns + +( This is to code which behavior the computed strategy refers to. ) +type asked_bhv = + | FunBhv of funbehavior option ( None means default behavior + when the function has no spec. This is useful to process internal + properties even if the function has no default behavior ) + | StmtBhv of Cil2cfg.node stmt * funbehavior + +let name_of_asked_bhv = function + | FunBhv (Some bhv) -> bhv.b_name + | FunBhv None -> Cil.default_behavior_name + | StmtBhv (_, _, bhv) -> bhv.b_name + +(* This is to code what properties the user asked for in a given behavior. ) +type asked_prop = + | AllProps + | OnlyPreconds + | NamedProp of string + | IdProp of Property.t + | CallPre of stmt Property.t option (** No specified property means all ) + +( a table to keep the information about the statement default specification + * associated with each edge in order to know in which strategy we should put a + * default annotation on this edge. When an edge has no information in the table, + * it means that the edge annotations belong to the [FunBhv] default behavior; + * and when we find a statement [s], it means that they belong to the [StmtBhv s] + * default behavior. The [int] information is only useful to build the table : + * when an edge is included in 2 different [StmtBhv] we only keep the one that + * has the fewer internal edges because it is necessarily included in the other. + ) +module HdefAnnotBhv = Cil2cfg.HE (struct type t = (stmt int) end) + +(* Finally, a configuration is associated to a strategy computation to + * summarize what is to be computed. ) +type strategy_info = { + kf : Kernel_function.t; + cfg : Cil2cfg.t; + cur_bhv : asked_bhv; + asked_bhvs : asked_bhv list; + asked_prop : asked_prop; + assigns_filter : asked_assigns; + def_annots_info : HdefAnnotBhv.t; +} + +(----------------------------------------------------------------------------) +( Adding things in the stategy ) +(----------------------------------------------------------------------------) + +( Select annotations to take as Hyp/Goal/... ) + +let pp_assigns_mode fmt config = + let str = match config.assigns_filter with + | NoAssigns -> "without assigns" + | OnlyAssigns -> "only with assigns" + | WithAssigns -> "both assigns or not" + in Format.fprintf fmt "%s" str + +let pp_asked_prop fmt config = match config.asked_prop with + | AllProps -> Format.fprintf fmt "all properties" + | OnlyPreconds -> Format.fprintf fmt "main preconditions" + | NamedProp s -> Format.fprintf fmt "properties %s" s + | IdProp p -> Format.fprintf fmt "property %s" (WpPropId.id_prop_txt p) + | CallPre (s, Some p) -> Format.fprintf fmt "pre %s at stmt %a" + (WpPropId.id_prop_txt p) Stmt.pretty_sid s + | CallPre (s, None) -> Format.fprintf fmt "all call preconditions at stmt %a" + Stmt.pretty_sid s + +let pp_strategy_info fmt config = + Format.fprintf fmt "'%a', " Kernel_function.pretty config.kf; + let _ = match config.cur_bhv with + | FunBhv _bhv -> + Format.fprintf fmt "behavior '%s'" (name_of_asked_bhv config.cur_bhv) + | StmtBhv (_, s, bhv) -> + Format.fprintf fmt "behavior '%s' of statement %d" bhv.b_name s.sid + in Format.fprintf fmt ", %a, %a" + pp_asked_prop config pp_assigns_mode config + +let cur_fct_default_bhv config = match config.cur_bhv with + | FunBhv None -> true + | FunBhv (Some bhv) -> bhv.b_name = Cil.default_behavior_name + | _ -> false + +let filter_status id = + Wp_parameters.StatusAll.get () || + match Property_status.get (WpPropId.property_of_id id) with + | Property_status.Best(Property_status.True, _) -> + Wp_parameters.StatusTrue.get () + | Property_status.Best(Property_status.Dont_know, _) -> + Wp_parameters.StatusMaybe.get () + | Property_status.Best((Property_status.False_if_reachable + | Property_status.False_and_reachable), _) -> + Wp_parameters.StatusFalse.get () + | Property_status.Never_tried -> true + | Property_status.Inconsistent _ -> false + +let filter_precond pid = + match WpPropId.property_of_id pid with + | Property.IPPredicate( Property.PKRequires _ , _ , Kglobal , _ ) -> true + | _ -> false + +let goal_to_select config pid = + let asked, take_it = + match config.assigns_filter, WpPropId.property_of_id pid with + | NoAssigns, Property.IPAssigns _ -> + "no assigns", false + | (OnlyAssigns | WithAssigns), Property.IPAssigns _ -> + "", true + | OnlyAssigns, _ -> "only assigns", false + | (NoAssigns | WithAssigns), _ -> "", true + in + let asked, (take_it, msg) = + if take_it then begin + match config.asked_prop with + | AllProps -> + "all", + if not (filter_status pid) + then false, " (skipped w.r.t status)" + else true, " (selected)" + | OnlyPreconds -> + "main precondition", + if not (filter_status pid) || not (filter_precond pid) + then false, " (main precondition only)" + else true, " (selected)" + | IdProp idp -> + ( Notice that if the user has explicitly selected a property, + * we consider it as a goal even if it has been proved already ) + (WpPropId.id_prop_txt idp), + (Property.equal (WpPropId.property_of_id pid) idp, "") + | CallPre (s_call, asked_pre) -> + let take_it, msg = WpPropId.select_call_pre s_call asked_pre pid in + let pre_txt = match asked_pre with None -> "all pre " + | Some pre -> WpPropId.id_prop_txt pre + in + pre_txt ^ " at stmt " ^ (string_of_int s_call.sid), + (take_it, msg) + | NamedProp str -> str, WpPropId.select_by_name str pid + end + else asked, (take_it, "") + in + debug "[goal_to_select] %s vs %a -> %s%s@." + asked WpPropId.pp_id_name pid (if take_it then "select" else "ignore") msg; + take_it + +(----------------------------------------------------------------------------) +( Add properties ) + +( TODO: still have to remove these fonctions... ) + +let kind_to_select config kind id = match kind with + | WpStrategy.Agoal -> + if goal_to_select config id then Some WpStrategy.Agoal else None + | WpStrategy.Aboth goal -> + let goal = goal && goal_to_select config id in + Some (WpStrategy.Aboth goal) + | WpStrategy.AcutB goal -> + let goal = goal && goal_to_select config id in + Some (WpStrategy.AcutB goal) + | WpStrategy.AcallPre goal -> + let goal = goal && goal_to_select config id in + Some (WpStrategy.AcallPre goal) + | WpStrategy.Ahyp | WpStrategy.AcallHyp -> Some kind + +let add_prop_inv_establish config acc kind s ca p = + let id = WpPropId.mk_establish_id config.kf s ca in + match kind_to_select config kind id with None -> acc + | Some kind -> WpStrategy.add_prop_loop_inv acc kind s id p + +let add_prop_inv_preserve config acc kind s ca p = + let id = WpPropId.mk_preserve_id config.kf s ca in + match kind_to_select config kind id with None -> acc + | Some kind -> WpStrategy.add_prop_loop_inv acc kind s id p + +let add_prop_inv_fixpoint config acc kind s ca p = + let id = WpPropId.mk_inv_hyp_id config.kf s ca in + match kind_to_select config kind id with None -> acc + | Some kind -> WpStrategy.add_prop_loop_inv acc kind s id p + +(----------------------------------------------------------------------------) +( Add Assigns ) + +let add_loop_assigns_goal config s (ca, assigns) acc = + let id = WpPropId.mk_loop_assigns_id config.kf s ca assigns in + match id with + None -> acc + | Some id -> + if goal_to_select config id then + let labels = NormAtLabels.labels_loop_assigns s in + let assigns' = NormAtLabels.preproc_assigns labels assigns in + let a_desc = WpPropId.mk_loop_assigns_desc s assigns' in + WpStrategy.add_assigns acc WpStrategy.Agoal id a_desc + else acc + +let add_stmt_assigns_goal config s acc b l_post = match b.b_assigns with + | WritesAny -> acc + | Writes assigns -> + let id = WpPropId.mk_stmt_assigns_id config.kf s b assigns in + match id with + | None -> acc + | Some id -> + if goal_to_select config id then + let labels = NormAtLabels.labels_stmt_assigns s l_post in + let assigns = NormAtLabels.preproc_assigns labels assigns in + let a_desc = WpPropId.mk_stmt_assigns_desc s assigns in + WpStrategy.add_assigns acc WpStrategy.Agoal id a_desc + else acc + +let add_fct_assigns_goal config acc tkind b = match b.b_assigns with + | WritesAny -> acc + | Writes assigns -> + let id = WpPropId.mk_fct_assigns_id config.kf b tkind assigns in + match id with + | None -> acc + | Some id -> + if goal_to_select config id then + let labels = NormAtLabels.labels_fct_assigns in + let assigns' = NormAtLabels.preproc_assigns labels assigns in + let a_desc = WpPropId.mk_kf_assigns_desc assigns' in + WpStrategy.add_assigns acc WpStrategy.Agoal id a_desc + else acc + +( ------------------------------------------------------------------------ ) +( --- Get annotations according to the behavior --- ) +( ------------------------------------------------------------------------ *) + +(** find the behavior named [name] in the list *) +let get_named_bhv name bhv_list = + try Some (List.find (fun b -> b.b_name = name) bhv_list) + with Not_found -> None + +(** Select in [bhv_list] the behavior that has to be processed + * according to [config] and [ki] current statement. *) +let get_behav config ki bh_list = match config.cur_bhv, ki with + | FunBhv _, Kglobal -> + get_named_bhv (name_of_asked_bhv config.cur_bhv) bh_list + | StmtBhv (_, s1, b), Kstmt s2 when s1.sid = s2.sid -> + get_named_bhv b.b_name bh_list + | _ -> None + +(** Tells weather the property belonging to the behaviors in [bhv_name_list] + * has to be considered according to [config]. ) +type test_behav_res = + | TBRno ( [cur_bhv] is not concerned ) + | TBRhyp ( the property belongs to [default_behavior], + but not to [cur_bhv] : it doesn't have to be a Goal + but can be considered as an hypothesis. ) + | TBRpart ( the property has to be taken as a Goal, but even if it is + proved for every [asked_bhvs], it will still be a partial proof. + TODO: use this to generate PKPartial ! ) + | TBRok ( Select as a Goal *) + +(** (see [test_behav_res] above). + * If the annotation doesn't have "for" names, it is a bit complicated because + * we have to know if the statement [s] is inside a stmt behavior or not. ) +let is_annot_for_config config node s_annot bhv_name_list = + let edges_before = Cil2cfg.pred_e config.cfg node in + debug "[is_annot_for_config] at sid:%d for %a ? @." + s_annot.sid (Wp_error.pp_string_list ~sep:" " ~empty:"<default>") + bhv_name_list; + let hyp_but_not_at_post n = ( don't take assert at post pgpt (see #564) ) + let s_post = match Cil2cfg.get_post_edges config.cfg n with + | [] -> None + | e::_ -> Cil2cfg.get_edge_next_stmt config.cfg e + in match s_post with + | Some s_post when s_post.sid = s_annot.sid -> TBRno + | _ -> TBRhyp + in + let res = match bhv_name_list with + | [] -> ( no spec 'for' in the property ) + begin + let e = match edges_before with + | e::_ -> e + | _ -> Wp_parameters.fatal "annot with no edge ?" + in + match config.cur_bhv with + | FunBhv _ when cur_fct_default_bhv config -> + begin + try + let _ = HdefAnnotBhv.find config.def_annots_info e in + TBRhyp + with Not_found -> TBRok + end + | StmtBhv (n, sb, b) when b.b_name = Cil.default_behavior_name -> + begin + try + let s,_ = HdefAnnotBhv.find config.def_annots_info e in + if s.sid = sb.sid then TBRok + else raise Not_found + with Not_found -> hyp_but_not_at_post n + end + | FunBhv _ -> TBRhyp + | StmtBhv (n,_,_) -> hyp_but_not_at_post n + end + | bhvs -> ( TODOopt : there is surely a better way to do this : ) + let asked_bhv = name_of_asked_bhv config.cur_bhv in + let goal = List.exists (fun bl -> bl = asked_bhv) bhvs in + if goal then + let full = ( TODO ) true + ( List.for_all (fun bl -> is_in bl config.asked_bhvs) bhvs ) + in (if full then TBRok else TBRpart) + else TBRno + in debug "[is_annot_for_config] -> %s@." + (match res with TBRok -> "ok" | TBRhyp -> "hyp" | TBRno -> "no" + | TBRpart -> "part"); + res + +let get_bhv_assumes spec l = + let rec get_assumes bhv_names = match bhv_names with [] -> [] + | bhv::tl -> + let l = match get_named_bhv bhv spec.spec_behavior with + | None -> Wp_parameters.warning "no %s behavior !?!?" bhv; + get_assumes tl + | Some b -> + (Ast_info.behavior_assumes b)::(get_assumes tl) + in l + in get_assumes l + +let add_fct_pre config acc spec = + let kf = config.kf in + let add_bhv_pre_hyp b acc = + let impl_assumes = false in + let kind = WpStrategy.Ahyp in + WpStrategy.add_prop_fct_bhv_pre acc kind kf b ~impl_assumes + in + let add_def_pre_hyp acc = + match Cil.find_default_behavior spec with None -> acc + | Some bdef -> add_bhv_pre_hyp bdef acc + in + let acc = match get_behav config Kglobal spec.spec_behavior with + | None -> add_def_pre_hyp acc + | Some b -> + let acc = + if not (Cil.is_default_behavior b) then add_def_pre_hyp acc else acc + in + let acc = + if WpStrategy.is_main_init kf then + let add_both acc p = + let id = WpPropId.mk_pre_id kf Kglobal b p in + let goal = goal_to_select config id in + let kind = WpStrategy.Aboth goal in + WpStrategy.add_prop_fct_pre acc kind kf b ~assumes:None p + in + let acc = List.fold_left add_both acc b.b_requires in + let add_hyp acc p = + let kind = WpStrategy.Ahyp in + WpStrategy.add_prop_fct_pre acc kind kf b ~assumes:None p + in List.fold_left add_hyp acc b.b_assumes + else add_bhv_pre_hyp b acc + in acc + in acc + + +let add_variant acc spec = ( TODO ) + let _ = match spec.spec_variant with None -> () + | Some v -> + Wp_parameters.warning "Ignored 'decrease' specification:@, %a@." + Cil.d_decreases v + in acc + +let add_terminates acc spec = ( TODO *) + let _ = match spec.spec_terminates with None -> () + | Some p -> Wp_parameters.warning + "Ignored 'terminates' specification:@, %a@." + !Ast_printer.d_predicate_named + (Logic_const.pred_of_id_pred p) + in acc + +let add_disjoint_behaviors_props config ki spec acc = + match spec.spec_disjoint_behaviors with [] -> acc + | l -> + let add_disj acc bhv_names = + let id = WpPropId.mk_disj_bhv_id (config.kf, ki, bhv_names) in + if goal_to_select config id then + begin + let prop = Ast_info.disjoint_behaviors spec bhv_names in + let labels = match ki with + | Kglobal -> NormAtLabels.labels_fct_pre + | Kstmt s -> NormAtLabels.labels_stmt_pre s + in WpStrategy.add_prop acc WpStrategy.Agoal labels id prop + end + else acc + in List.fold_left add_disj acc l + +let add_complete_behaviors_props config ki spec acc = + match spec.spec_complete_behaviors with [] -> acc + | l -> + let mk_prop acc bhv_names = + let id = WpPropId.mk_compl_bhv_id (config.kf, ki, bhv_names) in + if goal_to_select config id then + let prop = Ast_info.complete_behaviors spec bhv_names in + let labels = match ki with + | Kglobal -> NormAtLabels.labels_fct_pre + | Kstmt s -> NormAtLabels.labels_stmt_pre s + in WpStrategy.add_prop acc WpStrategy.Agoal labels id prop + else acc + in List.fold_left mk_prop acc l + +let add_behaviors_props config ki spec acc = + let add = match config.cur_bhv, ki with + | FunBhv _, Kglobal when cur_fct_default_bhv config -> true + | StmtBhv (_, cur_s, b), Kstmt s + when (s.sid = cur_s.sid && b.b_name = Cil.default_behavior_name) -> true + | _ -> false + in + if add then + let acc = add_complete_behaviors_props config ki spec acc in + let acc = add_disjoint_behaviors_props config ki spec acc in + acc + else acc + +(** Add the post condition of the whole spec as hypothesis. +* Add [old(assumes) => ensures] for all the behaviors, +* and also add an upper approximation of the merged assigns information. ) +let add_stmt_spec_post_as_hyp config v s spec acc = + let l_post = Cil2cfg.get_post_logic_label config.cfg v in + let add_bhv_post acc b = + let assumes = Some (Ast_info.behavior_assumes b) in + let add tk acc p = + WpStrategy.add_prop_stmt_post acc WpStrategy.Ahyp config.kf + s b tk l_post ~assumes p + in + let p_acc, e_acc = + WpStrategy.fold_bhv_post_cond ~warn:false (add Normal) (add Exits) acc b + in let p_acc = + WpStrategy.add_stmt_spec_assigns_hyp p_acc config.kf s l_post spec in + ( let e_acc = TODO, but crach at the moment... why ? + * add_spec_assigns_hyp config ki l_post e_acc spec in *) + p_acc, e_acc + in List.fold_left add_bhv_post acc spec.spec_behavior + +(** we want to prove this behavior: +* - add the requires as preconditions to both prove and use as hyp, +* - add the assumes as hypotheses, +* - add the postconditions as goals. +) +let add_stmt_bhv_as_goal config v s b (b_acc, (p_acc, e_acc)) = + let l_post = Cil2cfg.get_post_logic_label config.cfg v in + let assumes = None in ( [assumes] are used as separate hypotheses ) + let add_pre_hyp acc p = + WpStrategy.add_prop_stmt_pre acc WpStrategy.Ahyp config.kf s b ~assumes p + in + let add_pre_goal acc p = + let id = WpPropId.mk_pre_id config.kf (Kstmt s) b p in + let goal = goal_to_select config id in + let kind = WpStrategy.Aboth goal in + WpStrategy.add_prop_stmt_pre acc kind config.kf s b ~assumes p + in + let add_post tk acc p = + let id = WpPropId.mk_stmt_post_id config.kf s b (tk, p) in + let goal = goal_to_select config id in + let kind = WpStrategy.Aboth goal in + WpStrategy.add_prop_stmt_post acc kind config.kf s b tk l_post ~assumes p + in + + let b_acc = List.fold_left add_pre_goal b_acc b.b_requires in + let b_acc = List.fold_left add_pre_hyp b_acc b.b_assumes in + + let p_acc, e_acc = WpStrategy.fold_bhv_post_cond ~warn:true + (add_post Normal) (add_post Exits) (p_acc, e_acc) b + in + let p_acc = add_stmt_assigns_goal config s p_acc b l_post in + (let e_acc = TODO, but crach at the moment... why ? + add_stmt_assigns config s e_acc b l_post in ) + b_acc, (p_acc, e_acc) + +let add_stmt_spec_annots config v s spec ((b_acc, (p_acc, e_acc)) as acc) = + let acc = add_variant acc spec in + let acc = add_terminates acc spec in + match config.cur_bhv with + | StmtBhv (_n, cur_s, b) when s.sid = cur_s.sid -> + ( + begin match get_behav config (Kstmt s) spec.spec_behavior with + | None -> (* in some cases, it seems that we can have several spec + for the same statement -> not an error ) acc + | Some b -> + ) + let b_acc, a_acc = add_stmt_bhv_as_goal config v s b acc in + let b_acc = add_behaviors_props config (Kstmt s) spec b_acc in + b_acc, a_acc + | _ -> (* in all other cases, use the specification as hypothesis ) + let kind = WpStrategy.Aboth false in + let b_acc = + WpStrategy.add_prop_stmt_spec_pre b_acc kind config.kf s spec + in + let p_acc, e_acc = + add_stmt_spec_post_as_hyp config v s spec (p_acc, e_acc) + in b_acc, (p_acc, e_acc) + +(----------------------------------------------------------------------------) +( Call annotations ) +(----------------------------------------------------------------------------) + +let add_called_pre config called_kf s spec = + debug "[add_called_pre] for %a@." + Kernel_function.pretty called_kf; + let add_behav acc b = ( pre for behavior is [assumes => requires] ) + let assumes = (Ast_info.behavior_assumes b) in + let add_pre acc pre = + let id = mk_call_pre_id called_kf b s pre in + let kind = WpStrategy.AcallPre (goal_to_select config id) in + WpStrategy.add_prop_call_pre acc kind id ~assumes pre + in List.fold_left add_pre acc b.b_requires + in + let acc = + List.fold_left add_behav WpStrategy.empty_acc spec.spec_behavior + in + if acc = WpStrategy.empty_acc then + debug "no called precond for %a@." + Kernel_function.pretty called_kf; + acc + +let add_called_post called_kf termination_kind = + let spec = Kernel_function.get_spec called_kf in + debug "[add_called_post] '%s' for %a@." + (WpPropId.string_of_termination_kind termination_kind) + Kernel_function.pretty called_kf; + let add_behav acc b = + ( post for behavior is [\old(assumes) => ensures] ) + let kind = WpStrategy.AcallHyp in + let assumes = (Ast_info.behavior_assumes b) in + let add_post acc (tk, p) = + if tk = termination_kind + then WpStrategy.add_prop_call_post acc kind called_kf b tk ~assumes p + else acc + in List.fold_left add_post acc b.b_post_cond + in + let acc = List.fold_left add_behav WpStrategy.empty_acc spec.spec_behavior in + if acc = WpStrategy.empty_acc then + debug "no called %s postcondition for %a@." + (WpPropId.string_of_termination_kind termination_kind) + Kernel_function.pretty called_kf; + acc + +let get_call_annots config v s fct = + let l_post = Cil2cfg.get_post_logic_label config.cfg v in + match WpStrategy.get_called_kf fct with + | Some kf -> + let spec = Kernel_function.get_spec kf in + let before_annots = + if rte_precond_status config.kf then WpStrategy.empty_acc + else add_called_pre config kf s spec + in + let post_annots = add_called_post kf Normal in + let post_annots = + WpStrategy.add_call_assigns_hyp post_annots config.kf s + l_post (Some spec) + in + let exits_annots = add_called_post kf Exits in + before_annots, (post_annots, exits_annots) + + | None -> + Wp_parameters.warning + "call through function pointer not implemented yet: \ + ignore called function properties."; + let assigns_annots = + WpStrategy.add_call_assigns_hyp WpStrategy.empty_acc config.kf s + l_post None + in WpStrategy.empty_acc, (assigns_annots, assigns_annots) + +(----------------------------------------------------------------------------) +let add_variant_annot config s ca var_exp loop_entry loop_back = + let (vpos_id, vpos), (vdecr_id, vdecr) = + WpStrategy.mk_variant_properties config.kf s ca var_exp + in + let add acc kind id p = + WpStrategy.add_prop_loop_inv acc kind s id p + in + let add_hyp acc = + let acc = add acc WpStrategy.Ahyp vdecr_id vdecr in + add acc WpStrategy.Ahyp vpos_id vpos + in + let add_goal acc = + let acc = + if goal_to_select config vdecr_id then + add acc WpStrategy.Agoal vdecr_id vdecr + else acc + in if goal_to_select config vpos_id then + add acc WpStrategy.Agoal vpos_id vpos + else acc + in + let loop_back = + if cur_fct_default_bhv config then add_goal loop_back else add_hyp loop_back + (TODO: what about variant establishment ??? It seems that [0<v)] is not + * proved by induction anymore. Why ? ) + in loop_entry, loop_back + +let add_loop_invariant_annot config vloop s ca b_list inv acc = + let assigns, loop_entry, loop_back , loop_core = acc in + ( we have to prove that inv is true for each edge that goes + * in the loop, so we can assume that inv is true for each edge + * starting from this point. ) + match is_annot_for_config config vloop s b_list with + | TBRok + | TBRpart ( TODO: PKPartial ) + -> + if Wp_parameters.Invariants.get() then begin + let loop_core = add_prop_inv_fixpoint config loop_core + (WpStrategy.AcutB true) s ca inv + in assigns, loop_entry , loop_back , loop_core + end + else begin + let loop_entry = add_prop_inv_establish config loop_entry + WpStrategy.Agoal s ca inv in + let loop_back = add_prop_inv_preserve config loop_back + WpStrategy.Agoal s ca inv in + let loop_core = add_prop_inv_fixpoint config loop_core + WpStrategy.Ahyp s ca inv in + assigns, loop_entry , loop_back , loop_core + end + | TBRhyp -> ( TODO : add more inv hyp ? *) + let kind = + if Wp_parameters.Invariants.get() + then (WpStrategy.AcutB false) else WpStrategy.Ahyp + in + let loop_core = + add_prop_inv_fixpoint config loop_core kind s ca inv + in assigns, loop_entry , loop_back , loop_core + | TBRno -> acc + +let add_stmt_invariant_annot config v s ca b_list inv ((b_acc, a_acc) as acc) = + let add_to_acc k = + let b_acc = add_prop_inv_fixpoint config b_acc k s ca inv in + (b_acc, a_acc) + in + let acc = + match is_annot_for_config config v s b_list with + | TBRok | TBRpart -> add_to_acc (WpStrategy.AcutB true) + | TBRhyp -> add_to_acc (WpStrategy.AcutB false) + | TBRno -> acc + in acc + + +(** Returns the annotations for the three edges of the loop node: + * - loop_entry : goals for the edge entering in the loop + * - loop_back : goals for the edge looping to the entry point + * - loop_core : fix-point hypothesis for the edge starting the loop core + ) +let get_loop_annots config vloop s = + let do_annot a (assigns, loop_entry, loop_back , loop_core as acc) = + let ca = match a with User ca | AI (_, ca) -> ca in + match ca.annot_content with + | AInvariant (b_list, true, inv) -> + add_loop_invariant_annot config vloop s ca b_list inv acc + | AVariant (var_exp, None) -> + let loop_entry, loop_back = + add_variant_annot config s ca var_exp loop_entry loop_back + in assigns, loop_entry , loop_back , loop_core + | AVariant (_v, _rel) -> + Wp_parameters.warning "Ignoring loop variant with measure : %a" + !Ast_printer.d_code_annotation ca; + acc + | AAssigns (_,WritesAny) -> assert false + | AAssigns (b_list, Writes a) -> ( loop assigns ) + let h_assigns, g_assigns = assigns in + let check_assigns old cur = + match old with + None -> Some cur + | Some _ -> + Wp_parameters.fatal + "At most one loop assigns can be associated to a behavior" + in + let assigns = + match is_annot_for_config config vloop s b_list with + | TBRok | TBRpart -> + check_assigns h_assigns (ca,a), check_assigns g_assigns (ca,a) + | TBRhyp -> + check_assigns h_assigns (ca,a), g_assigns + | TBRno -> assigns + in (assigns, loop_entry , loop_back , loop_core) + | _ -> acc ( see get_stmt_annots ) + in + let acc = ((None,None), + WpStrategy.empty_acc, WpStrategy.empty_acc, WpStrategy.empty_acc) + in + let (h_assigns, g_assigns), loop_entry , loop_back , loop_core = + Annotations.single_fold_stmt do_annot s acc + in + let loop_back = match g_assigns with + | None -> loop_back + | Some a -> add_loop_assigns_goal config s a loop_back + in + let loop_core = + WpStrategy.add_loop_assigns_hyp loop_core config.kf s h_assigns + in (loop_entry , loop_back , loop_core) + +let get_stmt_annots config v s = + let do_annot a ((b_acc, (a_acc, e_acc)) as acc) = + let ca = Annotations.get_code_annotation a in + match ca.annot_content with + | AInvariant (b_list, loop_inv, inv) -> + if loop_inv then ( see get_loop_annots ) acc + else if Wp_parameters.Invariants.get() then + add_stmt_invariant_annot config v s ca b_list inv acc + else begin + Wp_parameters.warning + "ignored 'invariant' (use -wp-invariants option) : %a" + !Ast_printer.d_code_annotation ca; + acc + end + | AAssert (b_list,p) -> + let kf = config.kf in + let acc = match is_annot_for_config config v s b_list with + | TBRno -> acc + | TBRhyp -> + let b_acc = + WpStrategy.add_prop_assert b_acc WpStrategy.Ahyp kf s ca p + in (b_acc, (a_acc, e_acc)) + | TBRok | TBRpart -> + let id = WpPropId.mk_assert_id config.kf s ca in + let kind = WpStrategy.Aboth (goal_to_select config id) in + let b_acc = WpStrategy.add_prop_assert b_acc kind kf s ca p in + (b_acc, (a_acc, e_acc)) + in acc + | AAssigns (_b_list, _assigns) -> + ( loop assigns: see get_loop_annots ) acc + | AVariant (_v, _rel) -> ( see get_loop_annots ) acc + | APragma _ -> + Wp_parameters.warning "Ignored annotation:@ %a" + !Ast_printer.d_code_annotation ca; + acc + | AStmtSpec (b_list, spec) -> + if b_list <> [] then ( TODO ! ) + Wp_parameters.warning + "Ignored 'for %a' (generalize to all behavior)" + (Pretty_utils.pp_list ~sep:", " Format.pp_print_string) + b_list; + add_stmt_spec_annots config v s spec acc + in + let before_acc = WpStrategy.empty_acc in + let after_acc = WpStrategy.empty_acc in + let exits_acc = WpStrategy.empty_acc in + let acc = before_acc, (after_acc, exits_acc) in + Annotations.single_fold_stmt do_annot s acc + +let get_fct_pre_annots config spec = + let acc = WpStrategy.empty_acc in + let acc = add_fct_pre config acc spec in + let acc = add_behaviors_props config Kglobal spec acc in + let acc = add_variant acc spec in + let acc = add_terminates acc spec in + acc + +let get_fct_post_annots config tkind spec = + let acc = WpStrategy.empty_acc in + match get_behav config Kglobal spec.spec_behavior with + | None -> acc + | Some b -> + ( add the postconditions ) + let f_nothing () _ = () in + let add tk acc p = + let id = WpPropId.mk_fct_post_id config.kf b (tk, p) in + if goal_to_select config id then + WpStrategy.add_prop_fct_post acc WpStrategy.Agoal config.kf b tk p + else acc + in + let acc = match tkind with + | Normal -> + let acc, _ = + WpStrategy.fold_bhv_post_cond ~warn:true (add Normal) f_nothing (acc, ()) b + in acc + | Exits -> + let _, acc = + WpStrategy.fold_bhv_post_cond ~warn:false f_nothing (add Exits) ((), acc) b + in acc + | _ -> assert false + in ( also add the [assigns] ) + let acc = + if Kernel_function.is_definition config.kf + then add_fct_assigns_goal config acc tkind b + else WpStrategy.add_fct_bhv_assigns_hyp acc config.kf tkind b + in acc + +(----------------------------------------------------------------------------) +( Build graph annotation for the strategy ) +(----------------------------------------------------------------------------*) + +(** Builds tables that give hypotheses and goals relative to [b] behavior + * for edges of the cfg to consider during wp computation. + * [b = None] means that we only consider internal properties to select for the + * default behavior. This is useful when the function doesn't have any + * specification. + * @param asked_prop = Some id -> select only this goal (use all hyps). + ) +let get_behavior_annots config = + debug "build strategy for %a@." pp_strategy_info config; + let cfg = config.cfg in + let spec = Kernel_function.get_spec config.kf in + let annots = WpStrategy.create_tbl () in + + let get_node_annot v = + debug "get_node_annot for node %a" Cil2cfg.pp_node v; + match Cil2cfg.node_type v with + | Cil2cfg.Vstart | Cil2cfg.Vend -> () + + | Cil2cfg.VfctIn -> + let pre = get_fct_pre_annots config spec in + WpStrategy.add_on_edges annots pre (Cil2cfg.succ_e cfg v) + + | Cil2cfg.VfctOut -> + let post = get_fct_post_annots config Normal spec in + WpStrategy.add_on_edges annots post (Cil2cfg.succ_e cfg v) + + | Cil2cfg.Vexit -> + let post = get_fct_post_annots config Exits spec in + WpStrategy.add_on_edges annots post (Cil2cfg.succ_e cfg v) + + | Cil2cfg.VblkIn (Cil2cfg.Bstmt s, _) + | Cil2cfg.Vstmt s + | Cil2cfg.Vswitch (s,_) | Cil2cfg.Vtest (true, s, _) + -> + let stmt_annots = get_stmt_annots config v s in + WpStrategy.add_node_annots annots cfg v stmt_annots + + | Cil2cfg.Vcall (s,_,fct,_) -> + let stmt_annots = get_stmt_annots config v s in + WpStrategy.add_node_annots annots cfg v stmt_annots; + let call_annots = get_call_annots config v s fct in + WpStrategy.add_node_annots annots cfg v call_annots + + | Cil2cfg.Vloop (_, s) -> + let stmt_annots = get_stmt_annots config v s in + let before, _after = stmt_annots in + ( TODO: what about after ? ) + WpStrategy.add_loop_annots annots cfg v ~entry:before + ~back:WpStrategy.empty_acc ~core:WpStrategy.empty_acc; + debug "add_loop_annots stmt ok"; + let (entry , back , core) = get_loop_annots config v s in + debug "get_loop_annots ok"; + WpStrategy.add_loop_annots annots cfg v ~entry ~back ~core + + | Cil2cfg.Vloop2 _ -> ( nothing to do ) () + | Cil2cfg.VblkIn (_, _) | Cil2cfg.VblkOut (_, _) -> ( nothing ) () + | Cil2cfg.Vtest (false, _s, _) -> ( done in Cil2cfg.Vtest (true) ) () + in + Cil2cfg.iter_nodes get_node_annot cfg; + annots + +( ------------------------------------------------------------------------ ) +( --- Global Properties --- ) +( ------------------------------------------------------------------------ ) + +let add_global_annotations annots = + let globs = Globals.Annotations.get_all () in + let globs = List.map (fun (g, _generated) -> g) globs in + let rec do_g g = + let (source,_) = Cil_datatype.Global_annotation.loc g in + match g with + | Daxiomatic (_ax_name, globs,_) -> do_globs globs + | Dvolatile _ -> + ( nothing to do ) () + | Dfun_or_pred _ -> + ( will be processed while translation is needed ) () + | Dtype _ -> + ( will be processed while translation is needed ) () + | Dtype_annot (linfo,_) -> + Wp_parameters.warning ~source + "Type invariant not handled yet ('%s' ignored)" + linfo.l_var_info.lv_name; + () + | Dmodel_annot (linfo,_) -> + Wp_parameters.warning ~source + "Model fields not handled yet (model field '%s' ignored)" + linfo.l_var_info.lv_name; + () + | Dinvariant (linfo,_) -> + Wp_parameters.warning ~source + "Global invariant not handled yet ('%s' ignored)" + linfo.l_var_info.lv_name; + () + | Dlemma (name, is_axiom, labels, _, pred,_) -> + if not is_axiom then + Wp_parameters.warning ~once:true ~source + "Proof obligation for property '%s' not generated." name ; + WpStrategy.add_axiom annots name labels pred + and do_globs globs = List.iter do_g globs in + do_globs globs; + annots + +( ------------------------------------------------------------------------ ) +( --- Main functions to build the strategies --- ) +( ------------------------------------------------------------------------ ) + +let behavior_name_of_config config = + match config.cur_bhv with + | FunBhv None -> None + | FunBhv (Some b) when b.b_name = Cil.default_behavior_name -> None + | FunBhv (Some b) -> Some b.b_name + | StmtBhv (_, s, b) when b.b_name = Cil.default_behavior_name -> + Some ("default_for_stmt_"^(string_of_int s.sid))(TODO better name ?) + | StmtBhv (_, s, b) -> Some (b.b_name^"_stmt_"^(string_of_int s.sid)) + +let build_bhv_strategy config = + let annots = get_behavior_annots config in + let annots = add_global_annotations annots in + let desc = Pretty_utils.sfprintf "%a" pp_strategy_info config in + let new_loops = Wp_parameters.Invariants.get() in + WpStrategy.mk_strategy desc config.cfg (behavior_name_of_config config) + new_loops WpStrategy.SKannots annots + +( Visit the CFG to find all the internal statement specifications. + * (see [HdefAnnotBhv] documentation for infomation about this table). + ) +let internal_function_behaviors cfg = + let def_annot_bhv = HdefAnnotBhv.create 42 in + let get_stmt_bhv node stmt acc = + let add_bhv_info acc b = + if b.b_name = Cil.default_behavior_name then + begin + let _, int_edges = Cil2cfg.get_internal_edges cfg node in + let n = Cil2cfg.Eset.cardinal int_edges in + let reg e = + try + let (_old_s, old_n) = HdefAnnotBhv.find def_annot_bhv e in + if n < old_n then + ( new spec is included in the old one : override. *) + raise Not_found + with Not_found -> + HdefAnnotBhv.replace def_annot_bhv e (stmt, n) + in + Cil2cfg.Eset.iter reg int_edges + end; + (node, stmt, b)::acc + in + let spec_bhv_names acc annot = match annot with + | {annot_content = AStmtSpec (_,spec)} -> + List.fold_left add_bhv_info acc spec.spec_behavior + | _ -> Wp_parameters.fatal "filter on is_contract didn't work ?" + in + let annots = Annotations.get_filter Logic_utils.is_contract stmt in + let annots = List.map Annotations.get_code_annotation annots in + List.fold_left spec_bhv_names acc annots + in + let get_bhv n ((seen_stmts, bhvs) as l) = + match Cil2cfg.start_stmt_of_node n with None -> l + | Some s -> + if List.mem s.sid seen_stmts then l + else + let seen_stmts = s.sid::seen_stmts in + let bhvs = get_stmt_bhv n s bhvs in + (seen_stmts, bhvs) + in + let _, bhvs = Cil2cfg.fold_nodes get_bhv cfg ([], []) in + bhvs, def_annot_bhv + + +(** empty [bhv_names] means all (whatever [ki] is) ) +let find_behaviors kf cfg ki bhv_names = + let spec = Kernel_function.get_spec kf in + let f_bhvs = spec.spec_behavior in + let s_bhvs, def_annot_bhv = internal_function_behaviors cfg in + + let add_fct_bhv (def, acc) b = + let add () = + let def = if Cil.is_default_behavior b then true else def in + def, (FunBhv (Some b))::acc + in + if bhv_names = [] then add() + else match ki with + | None ( not specified ki ) | Some Kglobal -> + if List.mem b.b_name bhv_names then add () else (def, acc) + | Some Kstmt _ -> def, acc + in + + let add_stmt_bhv acc (n,s,b) = + if bhv_names = [] then (StmtBhv (n,s,b))::acc + else if List.mem b.b_name bhv_names then + let acc = match ki with + | None -> ( not specified ki ) (StmtBhv (n, s, b))::acc + | Some (Kstmt stmt) when stmt.sid = s.sid -> + (StmtBhv (n, s, b))::acc + | _ -> ( specified ki but not this one ) acc + in acc + else acc + in + + let f_bhvs = List.rev f_bhvs in ( for compatibility with previous version ) + let def, bhvs = List.fold_left add_fct_bhv (false, []) f_bhvs in + let bhvs = List.fold_left add_stmt_bhv bhvs s_bhvs in + let bhvs = + if def then ( fct default behavior already in ) bhvs + else if bhv_names = [] then (FunBhv None)::bhvs + else match ki with + | None ( not specified ki ) | Some Kglobal -> + if List.mem Cil.default_behavior_name bhv_names + then (FunBhv None)::bhvs + else bhvs + | Some Kstmt _ -> bhvs + in def_annot_bhv, bhvs + +(----------------------------------------------------------------------------) +( Unreachable ) +(----------------------------------------------------------------------------) + +let process_unreached_annots cfg = + debug "collecting unreachable annotations@."; + let unreached = Cil2cfg.unreachable_nodes cfg in + let kf = Cil2cfg.cfg_kf cfg in + let spec = Kernel_function.get_spec kf in + let add_id id acc = + if filter_status id then id::acc + else ( non-selected property : nothing to do ) acc + in + let do_post b tk acc (termk, _ as p) = + if tk = termk then add_id (WpPropId.mk_fct_post_id kf b p) acc else acc + in + let do_bhv termk acc b = List.fold_left (do_post b termk) acc b.b_post_cond in + let do_annot s a acc = + let ca = match a with User ca | AI (_, ca) -> ca in + add_id (WpPropId.mk_code_annot_id kf s ca) acc + in + let do_node acc n = + debug + "process annotations of unreachable node %a@." + Cil2cfg.pp_node_type n; + match n with + | Cil2cfg.Vstart -> Wp_parameters.fatal "Start must be reachable" + | Cil2cfg.VfctIn -> Wp_parameters.fatal "FctIn must be reachable" + | Cil2cfg.VfctOut -> List.fold_left (do_bhv Normal) acc spec.spec_behavior + | Cil2cfg.Vexit -> List.fold_left (do_bhv Exits) acc spec.spec_behavior + | Cil2cfg.Vstmt s + | Cil2cfg.VblkIn (Cil2cfg.Bstmt s, _) | Cil2cfg.Vcall (s, _, _, _) + | Cil2cfg.Vtest (true, s, _) | Cil2cfg.Vloop (_, s) | Cil2cfg.Vswitch (s,_) + -> Annotations.single_fold_stmt (do_annot s) s acc + | Cil2cfg.Vtest (false, _, _) | Cil2cfg.Vloop2 _ + | Cil2cfg.VblkIn _ | Cil2cfg.VblkOut _ | Cil2cfg.Vend -> acc + in + let annots = List.fold_left do_node [] unreached in + debug + "found %d unreachable annotations@." (List.length annots) ; + List.iter (fun pid -> set_unreachable pid) annots + +(----------------------------------------------------------------------------) +( Everything must go through here. ) +(----------------------------------------------------------------------------) + +let get_cfg kf = + if Wp_parameters.RTE.get () then compute_rte_for kf ; + let cfg = Cil2cfg.get kf in + let _ = process_unreached_annots cfg in + let do_dot = Wp_parameters.Dot.get () in + let _dot = if do_dot then Some (Cil2cfg.dot_cfg cfg) else None in + cfg + +let build_configs assigns kf behaviors ki property = + debug "[get_strategies] for behaviors names: %a@." + (Wp_error.pp_string_list ~sep:" " ~empty:"<none>") + (match behaviors with [] -> ["<all>"] | _ :: _ as l -> l) ; + let _ = match ki with + | None -> () + | Some Kglobal -> + debug + "[get_strategies] select in function properies@." + | Some (Kstmt s) -> + debug + "[get_strategies] select stmt %d properties@." s.sid + in + let cfg = get_cfg kf in + let property = match property with + | AllProps -> if Cil2cfg.cfg_spec_only cfg then OnlyPreconds else AllProps + | _ -> property + in + let def_annot_bhv, bhvs = find_behaviors kf cfg ki behaviors in + if bhvs = [] then + Wp_parameters.warning "[get_strategies] no behaviors found" + else + debug "[get_strategies] %d behaviors" + (List.length bhvs); + let mk_bhv_config bhv = { kf = kf; + cfg = cfg; + cur_bhv = bhv; + asked_prop = property; + asked_bhvs = bhvs; + assigns_filter = assigns; + def_annots_info = def_annot_bhv } + in List.map mk_bhv_config bhvs + +let get_strategies assigns kf behaviors ki property = + let configs = build_configs assigns kf behaviors ki property in + let rec add_stgs l = match l with [] -> [] + | config::tl -> + let stg = build_bhv_strategy config in + let stgs = stg::(add_stgs tl) in + match config.cur_bhv, config.asked_prop with + | FunBhv (Some b), AllProps -> + let froms = Property.ip_from_of_behavior kf Kglobal b in + let add acc ip = match ip with + | Property.IPFrom id_from -> + (WpFroms.get_strategy_for_from id_from)::acc + | _ -> acc + in List.fold_left add stgs froms + + | _, _ -> ( TODO ) stgs + in add_stgs configs + +(----------------------------------------------------------------------------) +( Public functions to build the strategies ) +(----------------------------------------------------------------------------) + +let get_precond_strategies p = + debug "[get_precond_strategies] %s@." + (WpPropId.id_prop_txt p); + match p with + | Property.IPPredicate (Property.PKRequires b, kf, Kglobal, _) -> + let strategies = + if WpStrategy.is_main_init kf then + get_strategies NoAssigns kf [b.b_name] None (IdProp p) + else [] + in + let call_sites = Kernel_function.find_syntactic_callsites kf in + let add_call_pre_stategy acc (kf_caller, stmt) = + let asked = CallPre (stmt, Some p) in + let strategies = get_strategies NoAssigns kf_caller [] None asked in + strategies @ acc + in + if call_sites = [] then + (Wp_parameters.warning + "no direct call sites for '%a': cannot check pre-conditions" + Kernel_function.pretty kf; + strategies) + else List.fold_left add_call_pre_stategy strategies call_sites + | _ -> + invalid_arg "[get_precond_strategies] not a function precondition" + +let get_call_pre_strategies stmt = + debug + "[get_call_pre_strategies] on statement %a@." Stmt.pretty_sid stmt; + match stmt.skind with + | Instr(Call(_,f,_,_)) -> + let strategies = match WpStrategy.get_called_kf f with + | None -> + Wp_parameters.warning + "call through function pointer not implemented yet: \ + cannot check pre-conditions for statement %a" + Stmt.pretty_sid stmt; + [] + | Some _kf_called -> + let kf_caller = Kernel_function.find_englobing_kf stmt in + let asked = CallPre (stmt, None) in + get_strategies NoAssigns kf_caller [] None asked + in strategies + | _ -> Wp_parameters.warning + "[get_call_pre_strategies] this is not a call statement"; [] + +let get_id_prop_strategies ?(assigns=WithAssigns) p = + debug "[get_id_prop_strategies] %s@." + (WpPropId.id_prop_txt p); + match p with + | Property.IPCodeAnnot (kf,_,ca) -> + let bhvs = match ca.annot_content with + | AAssert (l, _) | AInvariant (l, _, _) | AAssigns (l, _) -> l + | _ -> [] + in get_strategies assigns kf bhvs None (IdProp p) + | Property.IPAssigns (kf, _, Property.Id_code_annot _, _) + (loop assigns: belongs to the default behavior ) + | Property.IPDecrease (kf,_,_,_) -> + ( any variant property is attached to the default behavior of + * the function, NOT to a statement behavior ) + let bhvs = [ Cil.default_behavior_name ] in + get_strategies assigns kf bhvs None (IdProp p) + | Property.IPPredicate (Property.PKRequires _, _kf, Kglobal, _p) -> + get_precond_strategies p + | Property.IPFrom id_from -> + [ WpFroms.get_strategy_for_from id_from ] + | _ -> + let strategies = match Property.get_kf p with + | None -> Wp_parameters.warning + "WP of property outside functions: ignore %s" + (WpPropId.id_prop_txt p); [] + | Some kf -> + let ki = Some (Property.get_kinstr p) in + let bhv = match Property.get_behavior p with + | None -> Cil.default_behavior_name + | Some fb -> fb.b_name + in get_strategies assigns kf [bhv] ki (IdProp p) + in strategies + +let get_behavior_strategies ?(assigns=WithAssigns) kf bhvs = + let ki = None in + let stgs = get_strategies assigns kf bhvs ki AllProps in + stgs + +let get_function_strategies ?(assigns=WithAssigns) kf = + get_strategies assigns kf [] None AllProps + +( TODO: it could be better to first find the property in order + * to compute only in its functions and behaviors... + * At the moment [p_bhvs] is given as a hint (see [get_id_prop_strategies]) + ) +let get_prop_strategies ?(assigns=WithAssigns) kf (p_bhvs, prop_name) = + get_strategies assigns kf p_bhvs None (NamedProp prop_name) + +(----------------------------------------------------------------------------) +( +Local Variables: +compile-command: "make -C ../.." +End: +) +(----------------------------------------------------------------------------*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpAnnot.mli frama-c-20111001+nitrogen+dfsg/src/wp/wpAnnot.mli --- frama-c-20110201+carbon+dfsg/src/wp/wpAnnot.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpAnnot.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,120 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +( Every access to annotations have to go through here, + * so this is the place where we decide what the computation + * is allowed to use. ) + +open Cil_types + +(----------------------------------------------------------------------------*) + +(** splits a prop_id goals into prop_id parts for each sub-goals *) +val split : ( WpPropId.prop_id -> 'a -> unit ) -> WpPropId.prop_id -> + 'a Bag.t -> unit + +(** A proof accumulator for a set of related prop_id *) +type proof + +val create_proof : WpPropId.prop_id -> proof + (** to be used only once for one of the related prop_id *) + +val add_proof : proof -> WpPropId.prop_id -> Property.t list -> unit + (** accumulate int the proof the partial proof for this prop_id *) + +val is_composed : proof -> bool + (** whether a proof needs several lemma to be complete *) + +val is_proved : proof -> bool + (** wether all partial proofs have been accumulated or not ) + +val target : proof -> Property.t +val dependencies : proof -> Property.t list +val missing_rte : kernel_function -> string list + +(----------------------------------------------------------------------------) + +val get_called_post_conditions : kernel_function -> Property.t list +val get_called_exit_conditions : kernel_function -> Property.t list +val get_called_assigns : kernel_function -> Property.t list +val get_called_preconditions_at : kernel_function -> stmt -> Property.t list +val lookup_called_preconditions_at : kernel_function -> stmt -> Property.t list + +(----------------------------------------------------------------------------*) + +type asked_assigns = NoAssigns | OnlyAssigns | WithAssigns + +(** + * Defines how annotations are applied on the Cfg during the WP. + * - [~behaviors:bhv] : only annotations related + * to [b] in [bhv] are taken into account. + * Otherwise all behaviors are included. + * The default behavior is one behavior among the others. + * - [~property:pid] : only the mentioned property id is turned into a goal. + * Others are only used in hypothesis. + * Otherwise, annotations are generally turned into goals unless + * they already have a valid current status. + * - [~assigns] : filter in or out the assigns clauses. + * + **) +(* +val get_strategies : Cil2cfg.t + -> ?behaviors:string list + -> ?property:asked_prop + -> ?assigns:assigns + -> unit -> strategy list + *) + +(** Compute the strategies to prove the selected property. *) +val get_id_prop_strategies : + ?assigns:asked_assigns -> Property.t -> WpStrategy.strategy list + +val get_call_pre_strategies : stmt -> WpStrategy.strategy list + +(** Similar to [get_id_prop_strategies] but with a named property. +* (useful for command line option). +* The behavior list has to be the behaviors of the property. +* TODO: it should be removed when we will be able to compute it. ) +val get_prop_strategies : ?assigns:asked_assigns -> Kernel_function.t -> + (string list string) -> WpStrategy.strategy list + +(** Compute the strategy to prove all the properties of the behavior. +* Notice that is a property is related to several behaviors, +* it might not be fully proved with this strategy. +* Can return more strategies than names in the input list +* because a name can be used for several (disjoint) statement spec. +* *) +val get_behavior_strategies : + ?assigns:asked_assigns -> Kernel_function.t -> string list -> WpStrategy.strategy list + +(** Compute the strategies to prove all the properties of the selected function. +* ) +val get_function_strategies : + ?assigns:asked_assigns -> Kernel_function.t -> WpStrategy.strategy list + +(----------------------------------------------------------------------------) +( +Local Variables: +compile-command: "make -C ../.." +End: +) +(----------------------------------------------------------------------------*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wp_error.ml frama-c-20111001+nitrogen+dfsg/src/wp/wp_error.ml --- frama-c-20110201+carbon+dfsg/src/wp/wp_error.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wp_error.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,137 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ ) +( --- Exception Handling in WP --- ) +( ------------------------------------------------------------------------ ) + +exception Error of string string + +let current = ref "wp" +let set_model m = current := m + +let unsupported ?(model= !current) fmt = + let b = Buffer.create 80 in + Buffer.add_string b "unsupported " ; + let kf fmt = + Format.pp_print_flush fmt () ; + raise (Error(model,Buffer.contents b)) + in Format.kfprintf kf (Format.formatter_of_buffer b) fmt + +let not_yet_implemented ?(model= !current) fmt = + let b = Buffer.create 80 in + let kf fmt = + Format.pp_print_string fmt " not yet implemented" ; + Format.pp_print_flush fmt () ; + raise (Error(model,Buffer.contents b)) + in Format.kfprintf kf (Format.formatter_of_buffer b) fmt + +open Cil_types + +let pp_logic_label fmt label = + let name = match label with + | LogicLabel (_,l) -> l + | StmtLabel {contents=stmt} -> + let rec pickLabel = function + | [] -> Printf.sprintf "__unknown_label_%d" stmt.sid + | Label (l, _, _) :: _ -> l + | _ :: rest -> pickLabel rest + in pickLabel stmt.labels + in Format.pp_print_string fmt name + +let pp_assigns fmt asgns = + match asgns with + WritesAny -> Format.fprintf fmt "<undef>" + | _ -> + Format.fprintf fmt "@[<hov 2>%a@]" + (Cil.defaultCilPrinter#pAssigns "") asgns + +let pp_string_list ?(sep=Pretty_utils.space_sep) ~empty fmt l = + match l with [] -> Format.fprintf fmt "%s" empty + | _ -> Format.fprintf fmt "%a" + (Pretty_utils.pp_list ~sep Format.pp_print_string) l + + +type 'a cc = + | Result of 'a + | Warning of string * string (* model , message *) + +let protected = function + | Error (model, msg) -> + Some(model , msg) + | Log.FeatureRequest (plugin,msg) -> + Some(plugin , Printf.sprintf "%s not yet implemented" msg) + | Log.AbortError msg -> + Some("user error" , msg) + | _ -> None + +let protect exn = + match protected exn with + | Some(plugin,reason) -> plugin , reason + | None -> raise exn + +let protect_warning exn = + match protected exn with + | Some(src,reason) -> Warning(src,reason) + | None -> raise exn + +let protect_function f x = + try Result (f x) + with e -> protect_warning e + +let protect_translation f x y = + try Result (f x y) + with e -> protect_warning e + +let protect_translation3 f x y z = + try Result (f x y z) + with e -> protect_warning e + +let protect_translation4 f x y z t = + try Result (f x y z t) + with e -> protect_warning e + +let protect_translation5 f x y z t u = + try Result (f x y z t u) + with e -> protect_warning e + +let rec protect_map f = function + | [] -> Result [] + | x::xs -> + match f x with + | Result y -> + ( match protect_map f xs with + | Result ys -> Result (y :: ys) + | Warning _ as w -> w ) + | Warning(m,p) -> Warning(m,p) + +let rec name = function + | [] -> "" + | [x] -> x + | x::xs -> + let buffer = Buffer.create 80 in + Buffer.add_string buffer x ; + List.iter + (fun y -> if y <> "" then + ( Buffer.add_char buffer '-' ; + Buffer.add_string buffer y )) xs ; + Buffer.contents buffer diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wp_error.mli frama-c-20111001+nitrogen+dfsg/src/wp/wp_error.mli --- frama-c-20110201+carbon+dfsg/src/wp/wp_error.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wp_error.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,62 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +val name : string list -> string + +(* ------------------------------------------------------------------------ ) +( --- Exception Handling in WP --- ) +( ------------------------------------------------------------------------ ) + +open Cil_types + +exception Error of string string + (** To be raised a feature of C/ACSL cannot be supported by a memory model + or is not implemented, or ... ) + +val set_model : string -> unit + +val unsupported : ?model:string -> ('a,Format.formatter,unit,'b) format4 -> 'a +val not_yet_implemented : ?model:string -> ('a,Format.formatter,unit,'b) format4 -> 'a + +val pp_logic_label : Format.formatter -> logic_label -> unit + +val pp_assigns : + Format.formatter -> Cil_types.identified_term Cil_types.assigns -> unit + +val pp_string_list : ?sep:Pretty_utils.sformat -> empty:string -> + Format.formatter -> string list -> unit + +type 'a cc = + | Result of 'a + | Warning of string string (* source , reason ) + +val protect : exn -> string string (* source , reason *) + +val protect_function : ('a -> 'b) -> 'a -> 'b cc +val protect_translation : ('a -> 'b -> 'r) -> 'a -> 'b -> 'r cc +val protect_translation3 : ('a -> 'b -> 'c -> 'r) -> 'a -> 'b -> 'c -> 'r cc +val protect_translation4 : + ('a -> 'b -> 'c -> 'd -> 'r) -> 'a -> 'b -> 'c -> 'd -> 'r cc +val protect_translation5 : + ('a -> 'b -> 'c -> 'd -> 'e -> 'r) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'r cc + +val protect_map : ('a -> 'b cc) -> 'a list -> 'b list cc diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpFroms.ml frama-c-20111001+nitrogen+dfsg/src/wp/wpFroms.ml --- frama-c-20110201+carbon+dfsg/src/wp/wpFroms.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpFroms.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,594 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +let dkey = "froms" (* debugging key *) + +(** This file groups functions needed to check the fonctional dependencies ) + +open Cil_types + +exception NoFromForBhv +exception NoFromForLoop of stmt +exception NoFromForCall of stmt + +( -------------------------------------------------------------------------- *) +(** Build a full qualified name for logic_info about the nth from in the b +* behavior of the kf function. *) +let mk_name prefix kf ki b nth sufix = + let ki_info = match ki with Kglobal -> "" + | Kstmt s -> ("_stmt"^(string_of_int s.sid)) + in + let bhv_name = + if b.b_name = Cil.default_behavior_name then "" else ("_"^b.b_name) + in + Pretty_utils.sfprintf "%s%a%s%s_%d%s" + prefix + Kernel_function.pretty kf + bhv_name + ki_info + nth + sufix + +(** Build the logic type of the function that takes parameters of [in_types] +* and return an [out_type] result ([None] for a predicate) ) +let mk_linfo_type (out_type, in_types) = + let lvar_out_type = match out_type with Some t -> t + | None -> ( TODO: ugly ! but see in Logic_typing.logic_decl *) + Ctype Cil.voidType + in + let ltype = match in_types with [] -> lvar_out_type + | _ -> Larrow (in_types, lvar_out_type) + in ltype + +(** Build a [logic_info] with [fname] and the signature given by +* [(out_type, in_types)] (see {!mk_linfo_type}) +* TODO: should be [Cil_const.make_logic_info] when it be finished. *) +let make_logic_info fname (out_type, in_types) = + let ltype = mk_linfo_type (out_type, in_types) in + let lvar = Cil_const.make_logic_var fname ltype in + let mk_in_lvar t = Cil_const.make_logic_var "x" t in + let in_vars = List.map mk_in_lvar in_types in + let linfo = { + l_var_info = lvar; + l_labels = []; + l_tparams = []; + l_type = out_type; + l_profile = in_vars; + l_body = LBnone; + } in linfo + +(** Find the [logic_info] for the given name and signature. +* Build and register it if it doesn't exist yet. +* ) +let get_linfo name sgn = + let ptype = mk_linfo_type sgn in + let info_ok info = Logic_utils.is_same_type info.l_var_info.lv_type ptype in + match Logic_env.find_all_logic_functions name with + | [] -> + let linfo = make_logic_info name sgn in + Logic_utils.add_logic_function linfo; + linfo + | info::[] when info_ok info -> info + | _ -> Wp_parameters.fatal "several function named %s ???" name + +let mk_bhv_implicit_fun_name kf ki b n = + mk_name "FI_" kf ki b n "" + +let mk_loop_implicit_fun_name s n = + Pretty_utils.sfprintf "Floop%d_%d" s.sid n + +let get_pred_linfo kf ki bhv nth t = + let name = mk_name "Pfrom_" kf ki bhv nth ""in + get_linfo name (None, [t]) + +let get_init_linfo kf ki bhv n_assigns n_from t = + let name = mk_name "Init_" kf ki bhv n_assigns ("_"^(string_of_int n_from)) in + get_linfo name (Some t, [(Linteger*)]) + +(** Build the implicit function for the nth assign clause of behavior b +* in the ki element of function kf. *) +let get_implicit_fun name (out_type, inputs_type) = + let linfos = Logic_env.find_all_logic_functions name in + let f = match linfos with + | f::[] -> f + | _::_ -> Wp_parameters.fatal "several functions named %s" name + | [] -> + let linfo = make_logic_info name (Some out_type, inputs_type) in + Logic_utils.add_logic_function linfo; + linfo + in f +(** Build the lvalue [ \at (mlab, * (\at (addrlab, & elem))) ]. +* This is needed because the left part of assigns properties is an lvalue +* which address has to be interpreted in the pre-state ([addrlab]), +* but its value is to be considered in the post-state ([mlab]). *) +let build_elem_opt ~addrlab ~mlab elem = + let mk_mem_at t = + if Logic_utils.is_same_logic_label mlab Logic_const.here_label then t + else Logic_const.tat (t, mlab) + in + if Logic_utils.is_same_logic_label addrlab mlab then + Some (mk_mem_at elem) + else match elem.term_node with + | TLval (h, off) -> + let mk_addr_at t = Logic_const.tat (t, addrlab) in + let rec mk_at_off off = match off with TNoOffset -> off + | TField (f, off) -> TField (f, mk_at_off off) + | TIndex (i, off) -> TIndex (mk_addr_at i, mk_at_off off) + in + let off' = mk_at_off off in + let h' = match h with + | TVar _ | TResult _ -> h + | TMem p -> TMem (mk_addr_at p) + in + let lv' = TLval (h', off') in + let elem' = Logic_const.term lv' elem.term_type in + let elem' = mk_mem_at elem' in + Some (elem') + | _ -> + Wp_parameters.not_yet_implemented + "assigns left part is not a lvalue: %a" Cil.d_term elem + +(** see [build_elem_opt] above. *) +let build_elem ~addrlab ~mlab elem = + match build_elem_opt ~addrlab ~mlab elem with None -> assert false + | Some elem -> elem + +(** Build the left part of a contract [assigns] property +Process [\result] and [\exit_status] according to [termination_kind]. +Returns [None] if [out] is not compatible with [termination_kind]. +* ) +let build_post_output termination_kind output = + let out = output.it_content in + let out = match out.term_node with ( remove \at(\result,Post) *) + | Tat ({term_node=(TLval(TResult _,_) as tr)}, LogicLabel (_, "Post")) -> + Logic_const.term tr out.term_type + | _ -> out + in + match termination_kind, out.term_node with + | Exits, TLval (TResult _, _ ) -> None + | Normal, TLval (TVar{lv_name = "\\exit_status"},_) -> None + | _, _ -> + build_elem_opt + ~addrlab:Logic_const.old_label ~mlab:Logic_const.here_label out + +( Build [P(out)] where [out] is the left part of the assigns property. +Process [\result] and [\exit_status] according to [termination_kind]. +Returns [None] if [out] is not compatible with [termination_kind]. +) +let mk_assign_post kf bhv nth termination_kind (output, _) = + match build_post_output termination_kind output with + | None -> None + | Some out' -> + let linfos = get_pred_linfo kf Kglobal bhv nth out'.term_type in + let p = Logic_const.papp (linfos, [], [out']) in + Some (Logic_const.new_predicate p) + +module Vars = struct + let new_vars = ref [] + + let get_and_init () = + let vars = !new_vars in + new_vars := []; + vars + + let mk_new name ty = + (** Notice that [make_logic_var] create a frech variable. + * This is intended since several calls shouldn't share the same variable ! + ) + let v = Cil_const.make_logic_var name ty in + new_vars := v::!new_vars; + v +end + +( Build [out = f_n (inputs)]. +* The correct label \at should already be in [output] and [inputs]. +* @raise NoFromForBhv if [inputs = None] meaning [FromAny]. +) +let build_fimpl_eq fi_name output inputs = + let out_type = output.term_type in + let fun_impl = match inputs with + | None -> + let var = Vars.mk_new fi_name out_type in + Logic_const.tvar var + | Some inputs -> + let fimpl_sig = (out_type, List.map (fun i -> i.term_type) inputs) in + let fun_impl = get_implicit_fun fi_name fimpl_sig in + Logic_const.term (Tapp (fun_impl, [], inputs)) out_type + in let p_eq = Logic_const.prel (Req, output, fun_impl) in + p_eq + + +( @return the list of pair [from, out_i = implicit_fun_i (inputs)] +* for each [out_i \from inputs] assigns property of the behavior. +* The [from] part is for identification purpose later on. +* [implicit_fun_i] is the implicit fonction for the output. +* [kf] and [ki] give information to know there the specification comes from +* in order to build the names for the implicit functions. +* [termination_kind] is used to filter [\result] and [\exit_status] when needed. +*) +let bhv_from_hyps kf ki bhv l_froms termination_kind = + let add_assign (n, acc) ((output, inputs) as from) = + let acc = + match build_post_output termination_kind output with + | None -> acc + | Some output -> + let inputs = match inputs with + | FromAny -> None + | From inputs -> + let mk_input x = build_elem ~addrlab:Logic_const.old_label + ~mlab:Logic_const.old_label x.it_content + in + let inputs = List.map mk_input inputs in + Some inputs + in + let fi_name = mk_bhv_implicit_fun_name kf ki bhv n in + let p_eq = build_fimpl_eq fi_name output inputs in + (from, p_eq)::acc + in n+1, acc + in snd (List.fold_left add_assign (1, []) l_froms) + +(** For each behavior of the specification, and for each \from in the behavior, +* return a predicate which is [assumes => out_i = implicit_fun_i (inputs)]. +* If the assigns information is missing from a behavior, try to use +* the whole assigns information of the spec. +* @raise NoFromForBhv if we don't manage to compute the assigns information. +* See [bhv_from_hyps] above. +* ) +let post_of_spec_assigns kf ki spec termination_kind = + let add_behav (compl, acc) bhv = + match bhv.b_assigns with + | WritesAny -> ( skip ) compl, acc + | Writes l -> + ( post for behavior is [\old(assumes) => out = f(in)]) + let assumes = Ast_info.behavior_assumes bhv in + let compl = compl || Logic_utils.is_trivially_true assumes in + let assumes = Logic_const.pold assumes in + let l = bhv_from_hyps kf ki bhv l termination_kind in + let add_assume acc (from, p) = + let p = Logic_const.pimplies (assumes, p) in + (bhv, from, p)::acc + in let acc = List.fold_left add_assume acc l in + (compl, acc) + in + let compl = spec.spec_complete_behaviors <> [] in ( TODO: add dpds ? ) + let compl, acc = List.fold_left add_behav (compl, []) spec.spec_behavior in + if compl then acc + else ( some assigns information is missing: try to complete *) + match WpStrategy.assigns_upper_bound spec with + | None -> raise NoFromForBhv + | Some (b, l) -> + let l = bhv_from_hyps kf ki b l termination_kind in + List.fold_left (fun acc (from, p) -> (b, from, p)::acc) acc l + +(** Build the from hyp for the loop assigns *) +let inv_of_loop_from s n (output, inputs) = + let output = build_elem ~addrlab:Logic_const.here_label + ~mlab:Logic_const.here_label output.it_content + in + let pre_loop_lab = Clabels.mk_logic_label s in + let inputs =match inputs with + | FromAny -> None + | From inputs -> + let mk_input x = build_elem ~addrlab:Logic_const.here_label + ~mlab:pre_loop_lab x.it_content + in + let inputs = List.map mk_input inputs in + Some inputs + in + let fi_name = mk_loop_implicit_fun_name s n in + let p_eq = build_fimpl_eq fi_name output inputs in + p_eq + +(** Build [ xi = Init (i) /\ ...] forall inputs part of the assigns property. ) +let mk_assign_pre kf ki bhv nth inputs = + let get_init lv n = + let linfo = get_init_linfo kf ki bhv nth n lv.term_type in + Logic_const.term (Tapp (linfo, [], [(Logic_const.tinteger n)])) lv.term_type + in + let add_in (n, acc) input = + let lv = input.it_content in + let _name = lv.term_name in ( TODO process name ) + let init = get_init lv n in + let pre = Logic_const.prel (Req, lv, init) in + n+1, pre::acc + in + let _, pres = List.fold_left add_in (1, []) inputs in + Logic_const.new_predicate (Logic_const.pands pres) + +( -------------------------------------------------------------------------- *) +(** {2 Build Strategy} ) +( -------------------------------------------------------------------------- ) + +let annot_for_asked_bhv b_list asked_bhv = + b_list = [] || List.exists (fun x -> x = asked_bhv) b_list + +let get_loop_assigns_for_froms asked_bhv s = + let do_annot a acc = + let ca = match a with User ca | AI (_, ca) -> ca in + match ca.annot_content with + | AAssigns (b_list, Writes a) when annot_for_asked_bhv b_list asked_bhv -> + Some (ca,a) + | _ -> acc + in Annotations.single_fold_stmt do_annot s None + +let add_loop_assigns_hyp kf asked_bhv s acc = + let asgn_opt = get_loop_assigns_for_froms asked_bhv s in + let acc = WpStrategy.add_loop_assigns_hyp acc kf s asgn_opt in + match asgn_opt with + | None -> raise (NoFromForLoop s) + | Some (ca, assigns) -> + let add_assign (n, acc) from = + let inv = + try inv_of_loop_from s n from + with NoFromForBhv -> raise (NoFromForLoop s) + in + let id = WpPropId.mk_loop_from_id kf s ca from in + let labels = NormAtLabels.labels_loop_inv s in + let acc = WpStrategy.add_prop acc WpStrategy.Ahyp labels id inv in + n+1, acc + in + let _, acc = List.fold_left add_assign (1, acc) assigns in + acc + +let add_stmt_spec_assigns_hyp (p_acc, e_acc) kf s l_post spec = + let p_acc = + WpStrategy.add_stmt_spec_assigns_hyp p_acc kf s l_post spec + in ( TODO add_stmt_spec_assigns_hyp in e_acc but crach at the moment... ) + (p_acc, e_acc) + +let add_call_assigns_hyp (p_acc, e_acc) kf_caller s l_post spec = + let p_acc = + WpStrategy.add_call_assigns_hyp p_acc kf_caller s l_post (Some spec) + in ( TODO add_call_assigns_hyp in e_acc but crach at the moment... *) + (p_acc, e_acc) + +(** @raise NoFromForBhv is the assigns information is missing. ) +let add_spec_annots kf s l_post spec (b_acc, (p_acc, e_acc)) = + let kind = WpStrategy.Aboth false in + let b_acc = WpStrategy.add_prop_stmt_spec_pre b_acc kind kf s spec in + + let add_from acc (bhv, from, p) = + let id = + WpPropId.mk_bhv_from_id kf (Kstmt s) bhv from + in ( TODO use tk in id) + let labels = NormAtLabels.labels_stmt_post s l_post in + WpStrategy.add_prop acc WpStrategy.Ahyp labels id p + in + let p_froms = post_of_spec_assigns kf (Kstmt s) spec Normal in + let p_acc = List.fold_left add_from p_acc p_froms in + let e_froms = post_of_spec_assigns kf (Kstmt s) spec Exits in + let e_acc = List.fold_left add_from e_acc e_froms in + + let a_acc = add_stmt_spec_assigns_hyp (p_acc, e_acc) kf s l_post spec in + (b_acc, a_acc) + +let get_stmt_hyp kf asked_bhv s l_post = + let do_annot a acc = + let ca = Annotations.get_code_annotation a in + match ca.annot_content with + | AStmtSpec (b_list, spec) when annot_for_asked_bhv b_list asked_bhv -> + (try add_spec_annots kf s l_post spec acc + with NoFromForBhv -> ( TODO: not sure this is correct!) acc) + | _ -> ( ignore other annotations *) acc + in + let before_acc, after_acc, exits_acc = + WpStrategy.empty_acc, WpStrategy.empty_acc, WpStrategy.empty_acc in + let acc = before_acc, (after_acc, exits_acc) in + Annotations.single_fold_stmt do_annot s acc + +(** Collect the \from hypotheses of the function spectication. +* TODO: maybe we should also take the [ensures] properties ? +* @raise NoFromForBhv is the assigns information is missing. +) +let get_called_post kf termination_kind = + let spec = Kernel_function.get_spec kf in + Wp_parameters.debug ~dkey "[get_called_post] '%s' for %a@." + (WpPropId.string_of_termination_kind termination_kind) + Kernel_function.pretty kf; + let posts = post_of_spec_assigns kf Kglobal spec termination_kind in + let mk_prop acc (bhv, from, post) = + let id = WpPropId.mk_bhv_from_id kf Kglobal bhv from in + let labels = NormAtLabels.labels_fct_post in + WpStrategy.add_prop acc WpStrategy.AcallHyp labels id post + in List.fold_left mk_prop WpStrategy.empty_acc posts + +let get_call_hyp kf_caller s l_post fct = + match WpStrategy.get_called_kf fct with + | Some kf -> + let spec = Kernel_function.get_spec kf in + let before_annots = WpStrategy.empty_acc in + let post_annots = + try get_called_post kf Normal + with NoFromForBhv -> raise (NoFromForCall s) + in + let exits_annots = + try get_called_post kf Exits + with NoFromForBhv -> raise (NoFromForCall s) + in + let after_annots = post_annots, exits_annots in + let after_annots = + add_call_assigns_hyp after_annots kf_caller s l_post spec + in + before_annots, after_annots + | None -> + Wp_parameters.warning + "call through function pointer not implemented yet: \ + ignore called function properties."; + raise (NoFromForCall s) + +( Collect all the annotations to be used to prove one \from property of + * the function behavior **) +let get_fct_bhv_from_annots cfg bhv nth assign = + let kf = Cil2cfg.cfg_kf cfg in + let asked_bhv = bhv.b_name in + let annots = WpStrategy.create_tbl () in + let add_post v tk = match mk_assign_post kf bhv nth tk assign with + | None -> () + | Some post -> + let edges = Cil2cfg.succ_e cfg v in + let acc = WpStrategy.empty_acc in + (* TODO: goal_to_select for only one from ) + let kind = WpStrategy.Agoal in + let labels = NormAtLabels.labels_fct_assigns in + let id = WpPropId.mk_fct_from_id kf bhv tk assign in + let post = Logic_const.pred_of_id_pred post in + let acc = WpStrategy.add_prop acc kind labels id post in + WpStrategy.add_on_edges annots acc edges + in + let add_stmt_annots v s = + let l_post = Cil2cfg.get_post_logic_label cfg v in + let stmt_annots = get_stmt_hyp kf asked_bhv s l_post in + WpStrategy.add_node_annots annots cfg v stmt_annots + in + let get_node_annot v = + match Cil2cfg.node_type v with + | Cil2cfg.VfctIn -> () + ( Don't put the precondition here because we don't want to build + * (pre => post) => (pre' => post') but rather + * (pre /\ pre' /\ post => post') so we have to process the pre latter + * (see SKfroms) ) + + | Cil2cfg.VfctOut -> add_post v Normal + | Cil2cfg.Vexit -> add_post v Exits + + | Cil2cfg.VblkIn (Cil2cfg.Bstmt s, _) + | Cil2cfg.Vstmt s + | Cil2cfg.Vswitch (s,_) | Cil2cfg.Vtest (true, s, _) + -> add_stmt_annots v s + + | Cil2cfg.Vcall (s,_,fct,_) -> + let l_post = Cil2cfg.get_post_logic_label cfg v in + let call_annots = get_call_hyp kf s l_post fct in + WpStrategy.add_node_annots annots cfg v call_annots + + | Cil2cfg.Vloop (_, s) -> + add_stmt_annots v s; + let loop_core = + add_loop_assigns_hyp kf asked_bhv s WpStrategy.empty_acc in + let edges_to_head = Cil2cfg.succ_e cfg v in + WpStrategy.add_on_edges annots loop_core edges_to_head + | _ -> () + in + let _ = Cil2cfg.iter_nodes get_node_annot cfg in + annots + +let mk_strategy_for_fct_from cfg bhv pre ((out,from) as assign) = + let n = out.it_id in ( TODO: chose a better num with a user meaning ? ) + let kf = Cil2cfg.cfg_kf cfg in + let get_pre () = + let pre_init = match from with + | FromAny -> Wp_parameters.fatal "no from to prove" + | From inputs -> mk_assign_pre kf Kglobal bhv n inputs + in + let assumes = None in ( assumes are already hyp of the strategy. ) + WpStrategy.add_prop_fct_pre pre WpStrategy.Ahyp kf bhv ~assumes pre_init + in + let annots = get_fct_bhv_from_annots cfg bhv n assign in + let _ = WpStrategy.add_all_axioms annots in + let desc = + Pretty_utils.sfprintf "'%a', %d from property of '%s' behavior" + Kernel_function.pretty kf n bhv.b_name + in + let kind = WpStrategy.SKfroms { + WpStrategy.get_pre = get_pre; + WpStrategy.more_vars = Vars.get_and_init (); + } in + let new_loops = Wp_parameters.Invariants.get() in + let bname = if Cil.is_default_behavior bhv then "default" else bhv.b_name in + let bname = (bname^"_assign_"^(string_of_int n)) in + WpStrategy.mk_strategy desc cfg (Some bname) + new_loops kind annots + +let pp_err fmt e = + let no_from = "no \\from information" in + let pp_stmt_loc fmt s = + Format.fprintf fmt "@[%a@]" Cil.d_loc (Cil_datatype.Stmt.loc s) + in + match e with + | NoFromForCall s -> + Format.fprintf fmt "%s for call at @[%a@]" no_from pp_stmt_loc s + | NoFromForLoop s -> + Format.fprintf fmt "%s for loop at @[%a@]" no_from pp_stmt_loc s + | _ -> raise e + +let get_bhv_pre kf bhv = + let add_bhv_pre_hyp b acc = ( add both requires and assumes as precond ) + let kind = WpStrategy.Ahyp in + WpStrategy.add_prop_fct_bhv_pre acc kind kf b ~impl_assumes:false + in + let pre = add_bhv_pre_hyp bhv (WpStrategy.empty_acc) in + let pre = ( also add the default behavior precond *) + if (Cil.is_default_behavior bhv) then pre + else match Cil.find_default_behavior (Kernel_function.get_spec kf) with + | None -> pre + | Some bdef -> add_bhv_pre_hyp bdef pre + in + pre + +let get_strategy_for_from id_from = + let kf, ki, behavior_or_loop, from = id_from in + match ki, behavior_or_loop with + | Kglobal, Property.Id_behavior bhv -> + let cfg = Cil2cfg.get kf in + let pre = get_bhv_pre kf bhv in + mk_strategy_for_fct_from cfg bhv pre from + | _ -> Wp_parameters.not_yet_implemented "local \\from property check" + +(** Build strategies to prove the [from] properties of the function. +* At the moment, only the function behaviors are handled, +* but the strategies make use of the [from] properties of stmt spec, +* loops and called functions. ) +let get_strategies_for_froms kf = + if not (Kernel_function.is_definition kf) then + begin + Wp_parameters.warning + "Function %a has no body : cannot prove its \\from properties (skip)" + Kernel_function.pretty kf; + [] + end + else + let stmt_bhvs = Kernel_function.internal_function_behaviors kf in + if stmt_bhvs <> [] then + Wp_parameters.warning + "Not implemented: prove local \\from properties (skip)"; + ( TODO: \\from in loops. *) + let spec = Kernel_function.get_spec kf in + let cfg = Cil2cfg.get kf in + let add_bhv acc bhv = + let pre = get_bhv_pre kf bhv in + let add_assign_strategy acc (b,f) = + match f with + | FromAny -> acc + | From _l -> + let stg = mk_strategy_for_fct_from cfg bhv pre (b,f) in + stg::acc + in + match bhv.b_assigns with + | WritesAny -> acc + | Writes l -> + try List.fold_left add_assign_strategy acc l + with e -> + Wp_parameters.warning + "cannot check \\from properties of '%a':@,@[%a@]" + Kernel_function.pretty kf pp_err e; + acc + in List.fold_left add_bhv [] spec.spec_behavior diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpFroms.mli frama-c-20111001+nitrogen+dfsg/src/wp/wpFroms.mli --- frama-c-20110201+carbon+dfsg/src/wp/wpFroms.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpFroms.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,33 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + + +( Build a strategy for each of the \from property of the function behavior ) +val get_strategies_for_froms : Kernel_function.t -> WpStrategy.strategy list + +val get_strategy_for_from : Property.identified_from -> WpStrategy.strategy + +( +* TODO: add strategies for [from] properties of [loop assigns]. +* TODO: add strategies for stmt behaviors +* *) + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wp_gui.ml frama-c-20111001+nitrogen+dfsg/src/wp/wp_gui.ml --- frama-c-20110201+carbon+dfsg/src/wp/wp_gui.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wp_gui.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,390 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types + +(* ------------------------------------------------------------------------ ) +( --- RUN WP --- ) +( ------------------------------------------------------------------------ ) + +exception Stop + +type strategy_code = { + sp_target : string ; + sp_kf : Kernel_function.t option ; + sp_bhv : string list ; + sp_ip : Property.t option ; +} + +type strategy_call = { + sc_caller : Kernel_function.t ; + sc_called : Kernel_function.t ; + sc_callat : stmt ; +} + +type strategy = + | Snone + | Scode of strategy_code + | Scall of strategy_call + +let kind_of_property = function + | Property.IPCodeAnnot _ -> "annotation" + | Property.IPPredicate( Property.PKRequires _ , _ , Kglobal , _ ) -> "preconditions for callers" + | _ -> "property" + +let get_strategy localizable : strategy = + match localizable with + | Pretty_source.PStmt( kf , stmt ) + | Pretty_source.PLval( Some kf , Kstmt stmt , _ ) + | Pretty_source.PTermLval( Some kf , Kstmt stmt , _ ) + -> + begin + match stmt with + | { skind=Instr(Call(_,e,_,_)) } -> + begin + match WpStrategy.get_called_kf e with + | None -> Snone + | Some called -> + Scall { + sc_caller = kf ; + sc_called = called ; + sc_callat = stmt ; + } + end + | _ -> Snone +( + Scode { + sp_target = "function contract" ; + sp_kf = Some kf ; + sp_bhv = [] ; + sp_ip = None ; + } +) + end + + | Pretty_source.PVDecl (Some kf,{vglob=true}) -> + Scode { + sp_target = "function contract" ; + sp_kf = Some kf ; + sp_bhv = [] ; + sp_ip = None ; + } + + | Pretty_source.PIP ip -> + Scode { + sp_target = kind_of_property ip ; + sp_kf = Property.get_kf ip ; + sp_bhv = + Extlib.may_map + ~dft:[] + (fun x -> [ x.b_name ]) + (Property.get_behavior ip) ; + sp_ip = Some ip ; + } + + | Pretty_source.PVDecl _ + | Pretty_source.PLval _ + | Pretty_source.PTermLval _ + | Pretty_source.PGlobal _ -> + Snone + +let run_and_prove (main_ui:Design.main_window_extension_points) strategy = + try + begin + match strategy with + | Snone -> raise Stop + | Scode s -> + Register.wp_compute + s.sp_kf s.sp_bhv s.sp_ip + | Scall s -> + Register.wp_compute_call + ~kf_caller:s.sc_caller + ~kf_called:s.sc_called + s.sc_callat + end ; + main_ui#rehighlight () ; + Po_navigator.refresh_panel () ; + Task.on_server_stop + (Prover.server ()) + (fun () -> + Po_navigator.refresh_status () ; + if Wp_parameters.RTE.get () ( TODO[LC] can be optimized ) + then main_ui#redisplay () + else main_ui#rehighlight () ) ; + with Stop -> () + +( ------------------------------------------------------------------------ ) +( --- Source Highlighter --- ) +( ------------------------------------------------------------------------ ) + +let wp_highlight + (buffer:GSourceView2.source_buffer) + (localizable:Pretty_source.localizable) + ~(start:int) ~(stop:int) = + match localizable with + | Pretty_source.PStmt(_,({ skind=Instr(Call(_,e,_,_)) } as stmt)) -> + (match WpStrategy.get_called_kf e with + | Some kg -> + let ips = WpAnnot.lookup_called_preconditions_at kg stmt in + if ips <> [] then + let validity = Property_status.Feedback.get_conjunction ips in + Design.Feedback.mark buffer ~start ~stop validity + | None -> ()) + | _ -> () + +( ------------------------------------------------------------------------ ) +( --- Source Callback --- ) +( ------------------------------------------------------------------------ ) + +let is_rte_generated kf = + List.for_all + (fun (_,_,lookup,_) -> lookup kf) + (!Db.RteGen.get_all_status ()) + +let is_rte_precond kf = + let (_,_,lookup,_) = !Db.RteGen.get_precond_status () in (lookup kf) + +let add_rte_menu + (popup_factory:GMenu.menu GMenu.factory) + (main_ui:Design.main_window_extension_points) localizable = + begin + match localizable with + | Pretty_source.PVDecl (Some kf,{vglob=true}) -> + if not (is_rte_generated kf) then + ignore (popup_factory#add_item "Insert WP-safety guards" + ~callback:(fun () -> !Db.RteGen.do_all_rte kf ; main_ui#redisplay ())) ; + if not (is_rte_precond kf) then + ignore (popup_factory#add_item "Insert all callees contract" + ~callback:(fun () -> !Db.RteGen.do_precond kf ; main_ui#redisplay ())) ; + | Pretty_source.PStmt(kf,({ skind=Instr(Call _) })) -> + if not (is_rte_precond kf) then + ignore (popup_factory#add_item "Insert callees contract (all calls)" + ~callback:(fun () -> !Db.RteGen.do_precond kf ; main_ui#redisplay ())) ; + | _ -> () + end + +let add_wp_menu + (popup_factory:GMenu.menu GMenu.factory) + (main_ui:Design.main_window_extension_points) + localizable = + let strategy = get_strategy localizable in + let add_wp_run descr = + ignore (popup_factory#add_item + (Printf.sprintf "Prove %s by WP" descr) + ~callback:(fun () -> run_and_prove main_ui strategy)) + in + match strategy with + | Snone -> () + | Scall _ -> add_wp_run "call preconditions" + | Scode { sp_target = descr } -> add_wp_run descr + +let wp_select + (popup_factory:GMenu.menu GMenu.factory) + (main_ui:Design.main_window_extension_points) + ~button localizable = + match button with + | 3 -> ( Popup Menu: ) + add_wp_menu popup_factory main_ui localizable ; + add_rte_menu popup_factory main_ui localizable ; + | _ -> ( Other buttons... ) () + +( ------------------------------------------------------------------------ ) +( --- WP Panel --- ) +( ------------------------------------------------------------------------ ) + +let wp_model_menu = [ + "Hoare" , "Hoare" ; + "Store" , "Store" ; + "Runtime" , "Runtime" ; +] + +type p_select = + | NoProver + | Prover of string + +let wp_prover_menu = [ + "None" , NoProver ; + "Alt-Ergo" , Prover "alt-ergo" ; + "Coq" , Prover "coqide" ; + "Z3" , Prover "z3" ; + "Simplify" , Prover "simplify" ; + "Vampire" , Prover "vampire"; + "CVC3" , Prover "cvc3" ; + "Yices" , Prover "yices" ; + "Zenon" , Prover "zenon" ; +] + +let wp_prover_get () = + match Wp_parameters.Prover.get () with + | "alt-ergo" -> Prover "alt-ergo" + | "coqide" -> Prover "coqide" + | "coq" -> Wp_parameters.Prover.set "coqide" ; Prover "coqide" + | "simplify" -> Prover "simplify" + | "vampire" -> Prover "vampire" + | "z3" -> Prover "z3" + | "cvc3" -> Prover "cvc3" + | "yices" -> Prover "yices" + | "zenon" -> Prover "zenon" + | _ -> NoProver + +let wp_dir = ref + (try + let home = Sys.getenv "HOME" in + if Sys.file_exists home && Sys.is_directory home + then home else raise Not_found + with Not_found -> Sys.getcwd ()) + +let wp_script () = + let file = GToolbox.select_file + ~title:"Script File for Coq proofs" + ~dir:wp_dir ~filename:"wp.script" () + in + match file with + | Some f -> Wp_parameters.Script.set f + | None -> () + +let wp_prover_set = function + | Prover p -> + if p="coqide" && Wp_parameters.Script.get() = "" + then wp_script () ; + Wp_parameters.Prover.set p + | NoProver -> + Wp_parameters.Prover.set "none" + +let wp_panel (main_ui:Design.main_window_extension_points) = + let vbox = GPack.vbox () in + let demon = Gtk_form.demon () in + let packing = vbox#pack in + let form = new Gtk_form.form ~packing in + + form#label "Model" ; + Gtk_form.menu wp_model_menu + ~tooltip:"Memory model selection" ~packing:form#item + Wp_parameters.Model.get Wp_parameters.Model.set demon ; + + form#label "Prover" ; + Gtk_form.menu wp_prover_menu + ~tooltip:"Prover selection" + ~packing:form#item + wp_prover_get wp_prover_set demon ; + + let options = GPack.hbox ~spacing:8 ~packing () in + + Gtk_form.check ~label:"RTE" + ~tooltip:"Generates RTE guards for WP" + ~packing:options#pack + Wp_parameters.RTE.get Wp_parameters.RTE.set demon ; + + Gtk_form.check ~label:"Split" + ~tooltip:"Split cunjunctions into sub-goals" + ~packing:options#pack + Wp_parameters.Split.get Wp_parameters.Split.set + demon ; + + Gtk_form.check ~label:"Invariants" + ~tooltip:"Alternative WP for loop with arbitrary invariants" + ~packing:options#pack + Wp_parameters.Invariants.get Wp_parameters.Invariants.set demon ; + + Gtk_form.check ~label:"Trace" + ~tooltip:"Report proof information from the provers" + ~packing:options#pack + Wp_parameters.ProofTrace.get Wp_parameters.ProofTrace.set demon ; + + let control = GPack.hbox ~packing () in + + Gtk_form.button ~label:"Scripts" + ~tooltip:"Script file for saving Coq proofs" + ~callback:wp_script ~packing:control#pack () ; + + Gtk_form.label ~text:"Timeout" ~packing:control#pack () ; + Gtk_form.spinner ~lower:0 ~upper:100000 + ~tooltip:"Timeout for proving one proof obligation" + ~packing:control#pack + Wp_parameters.Timeout.get Wp_parameters.Timeout.set demon ; + + Gtk_form.label ~text:"Process" ~packing:control#pack () ; + Gtk_form.spinner ~lower:1 ~upper:32 + ~tooltip:"Maximum number of parallel running provers" + ~packing:control#pack + Wp_parameters.Procs.get + (fun n -> + Wp_parameters.Procs.set n ; + ignore (Prover.server ()) ( to make server procs updated is server exists ) + ) demon ; + + let pbox = GPack.hbox ~packing ~show:false () in + let progress = GRange.progress_bar ~packing:(pbox#pack ~expand:true ~fill:true) () in + let cancel = GButton.button ~packing:(pbox#pack ~expand:false) ~stock:`STOP () in + cancel#misc#set_sensitive false ; + let server = Prover.server () in + ignore (cancel#connect#released (fun () -> Task.cancel_all server)) ; + let inactive = (0,0) in + let state = ref inactive in + Task.on_server_activity server + (fun () -> + let scheduled = Task.scheduled server in + let terminated = Task.terminated server in + let remaining = scheduled - terminated in + + if remaining <= 0 then + ( pbox#misc#hide () ; state := inactive ; cancel#misc#set_sensitive false ) + else + begin + if !state = inactive then + ( pbox#misc#show () ; cancel#misc#set_sensitive true ) ; + + let s_term , s_sched = !state in + + if s_term <> terminated + then ( Po_navigator.refresh_status () ; main_ui#rehighlight () ) ; + if s_sched <> scheduled || s_term <> terminated then + begin + progress#set_text (Printf.sprintf "%d / %d" terminated scheduled) ; + progress#set_fraction + (if scheduled = 0 then 1.0 else (float terminated /. float scheduled)) ; + end ; + + state := (terminated,remaining) ; + end) ; + "WP" , vbox#coerce , Some (Gtk_form.refresh demon) + +( ------------------------------------------------------------------------ ) +( --- Registering WP GUI --- ) +( ------------------------------------------------------------------------ ) + +let main main_ui = + begin + main_ui#register_source_highlighter wp_highlight ; + main_ui#register_source_selector wp_select ; + main_ui#register_panel wp_panel ; + end + +let () = Design.register_extension main + +( ------------------------------------------------------------------------ ) + +( + Local Variables: + compile-command: "make -C ../.." + End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/Wp.mli frama-c-20111001+nitrogen+dfsg/src/wp/Wp.mli --- frama-c-20110201+carbon+dfsg/src/wp/Wp.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/Wp.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,28 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* $Id: Wp.mli 15451 2011-10-04 11:34:51Z signoles $ *) + +(** Weakest preconditions. *) + +(** No function is directly exported: they are registered in + {!Db.Properties}. *) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpo.ml frama-c-20111001+nitrogen+dfsg/src/wp/wpo.ml --- frama-c-20110201+carbon+dfsg/src/wp/wpo.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpo.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,585 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ ) +( --- Proof Obligations --- ) +( ------------------------------------------------------------------------ ) + +open Cil_types + +type po = t and t = +{ + po_fun : kernel_function ; ( function ) + po_bhv : string option ; ( behavior ) + po_pid : WpPropId.prop_id ; ( goal target property ) + po_gid : string ; ( goal identifier ) + po_env : string ; ( goal environment identifier ) + po_model : string ; ( model identifier ) + po_updater : Emitter.t ; ( property status updater ) + po_name : string ; ( goal informal name ) + po_dep : Property.t list ; ( dependencies ) + po_warn : warning list ; ( warnings ) +} + +and warning = { + wrn_loc : Lexing.position ; + wrn_severe : bool ; + wrn_source : string ; + wrn_reason : string ; + wrn_effect : string ; +} + +module PODatatype = + Datatype.Make( + struct + type t = po + include Datatype.Undefined + let name = "Wpo.po" + let reprs = + [ { po_fun = List.hd Kernel_function.reprs; + po_bhv = Some "Cil.default_behavior_name"; + po_pid = List.hd WpPropId.Prop_id_datatype.reprs; + po_gid = "xxx"; + po_env = ""; + po_model = "Store"; + po_updater = List.hd Emitter.reprs; + po_name = "dummy"; + po_dep = []; + po_warn = [];}] + end) + +type prover = + | Why of string ( Prover via WHY ) + | AltErgo ( Alt-Ergo ) + | Coq ( Coq and Coqide ) + | WP ( Simplifier ) + +module ProverType = + Datatype.Make + (struct + type t = prover + include Datatype.Undefined + let name = "Wpo.prover" + let reprs = [ AltErgo; Coq; WP; Why "z3" ] + end) + +type language = + | L_why + | L_coq + | L_altergo + +type result = + | Valid + | Invalid + | Unknown + | Timeout + | Computing + | Failed of string + +module ResultType = + Datatype.Make + (struct + type t = result + include Datatype.Undefined + let name = "Wpo.result" + let reprs = [ Valid; Invalid; Unknown; Timeout; + Computing; Failed "error" ] + end) + +( -------------------------------------------------------------------------- ) +( --- Pretty Printers --- ) +( -------------------------------------------------------------------------- ) + +let pp_warning fmt w = + begin + Format.fprintf fmt + "@[<v 0>%s:%d: warning from %s:@\n" + w.wrn_loc.Lexing.pos_fname + w.wrn_loc.Lexing.pos_lnum + w.wrn_source ; + if w.wrn_severe then + Format.fprintf fmt " - Warning: %s, looking for context inconsistency" + w.wrn_effect + else + Format.fprintf fmt " - Warning: %s" w.wrn_effect ; + Format.fprintf fmt "@\n Reason: %s@]" w.wrn_reason ; + end + +let pp_dependency kf fmt d = + Format.fprintf fmt " - Assumes %a" (Description.pp_localized ~kf:(`Context kf) ~ki:false) d + +let pp_depend fmt d = + Format.fprintf fmt " - Assumes %a" (Description.pp_localized ~kf:`Always ~ki:false) d + +let pp_prover fmt = function + | AltErgo -> Format.pp_print_string fmt "Alt-Ergo" + | Coq -> Format.pp_print_string fmt "Coq" + | Why smt -> + if Wp_parameters.debug_atleast 1 then + Format.pp_print_string fmt ("Why:"^(String.capitalize smt)) + else + Format.pp_print_string fmt (String.capitalize smt) + | WP -> Format.fprintf fmt "WP" + +let pp_language fmt = function + | L_altergo -> Format.pp_print_string fmt "Alt-Ergo" + | L_coq -> Format.pp_print_string fmt "Coq" + | L_why -> Format.pp_print_string fmt "Why" + +let pp_result fmt = function + | Valid -> Format.pp_print_string fmt "Valid" + | Invalid -> Format.pp_print_string fmt "Invalid" + | Unknown -> Format.pp_print_string fmt "Unknown" + | Timeout -> Format.pp_print_string fmt "Timeout" + | Computing -> Format.pp_print_string fmt "Computing" + | Failed msg -> + if Wp_parameters.debug_atleast 1 + then Format.fprintf fmt "Failed@\nError: %s" msg + else Format.fprintf fmt "Failed" + +( -------------------------------------------------------------------------- ) +( --- Proof Collector --- ) +( -------------------------------------------------------------------------- ) + +module Hproof = Hashtbl.Make(Datatype.Pair(Datatype.String)(Property)) + ( Table indexed by ( Model name , Property proved ) ) + +module Results = +struct + type t = (prover,result) Hashtbl.t + let create () = Hashtbl.create 7 + let replace t p r = Hashtbl.replace t p r + let clear t = Hashtbl.clear t + let remove t p = Hashtbl.remove t p + let get t p = try Some (Hashtbl.find t p) with Not_found -> None + let iter = Hashtbl.iter +end + +( -------------------------------------------------------------------------- ) +( --- Wpo Database --- ) +( -------------------------------------------------------------------------- ) + +module WPO = +struct + type t = po + let hash t = Hashtbl.hash t.po_gid + let equal a b = (a.po_gid = b.po_gid) + let compare a b = + let c = String.compare a.po_model b.po_model in + if c<>0 then c else + let c = String.compare a.po_name b.po_name in + if c<>0 then c else + let c = WpPropId.compare_prop_id a.po_pid b.po_pid in + if c<>0 then c else String.compare a.po_gid b.po_gid +end + +module Kfmap = Kernel_function.Map +module Imap = Map.Make(String) +module WPOset = Set.Make(WPO) +module Hpo = Hashtbl.Make(WPO) + +type system = { + mutable environments : int Imap.t ; + ( context name -> # of environment ) + mutable last : (string int * string) option ; + (* last environment generated ) + mutable index : WPOset.t Imap.t Kfmap.t ; + ( all Wpo added, indexed by kernel-function and behavior ) + proofs : WpAnnot.proof Hproof.t ; + ( proof collector ) + results : Results.t Hpo.t ; + ( results collector ) +} + +let system = { + last = None ; + environments = Imap.empty ; + index = Kfmap.empty ; + proofs = Hproof.create 131 ; + results = Hpo.create 131 ; +} + +( -------------------------------------------------------------------------- ) +( --- Getters --- ) +( -------------------------------------------------------------------------- ) + +let get_gid = + Dynamic.register + ~plugin:"Wp" "Wpo.get_gid" ~journalize:false + (Datatype.func PODatatype.ty Datatype.string) + (fun g -> g.po_gid) + +let get_prop_id = + Dynamic.register + ~plugin:"Wp" "Wpo.get_prop_id" ~journalize:false + (Datatype.func PODatatype.ty WpPropId.Prop_id_datatype.ty) + (fun g -> g.po_pid) + +( ------------------------------------------------------------------------ ) +( --- WPO Construction --- ) +( ------------------------------------------------------------------------ ) + +( A WPO is uniquely determined by : + 1. The context name (unique per updater by construction) + 2. The kernel-function + 3. The behavior + 4. The target prop-id +) + +let gid ~context ~kf ~bhv ~propid = + let gname = WpPropId.prop_id_name propid in + let fname = Kernel_function.get_name kf in + match bhv with + | Some b -> Printf.sprintf "%s_%s_%s_%s" context fname b gname + | None -> Printf.sprintf "%s_%s_%s" context fname gname + +( -------------------------------------------------------------------------- ) +( --- Registry of POs --- ) +( -------------------------------------------------------------------------- ) + +let clear () = + begin + system.index <- Kfmap.empty ; + Hproof.clear system.proofs ; + Hpo.clear system.results ; + end + +let env_name model k = Printf.sprintf "%s_env%d" model k + +let new_env ~context = + let k = + try succ (Imap.find context system.environments) + with Not_found -> 1 in + system.environments <- Imap.add context k system.environments ; + let env = env_name context k in + system.last <- Some (context,k,env) ; env + +let release_env ~env = + match system.last with + | Some (model,k0,env0) -> + if env0 = env then + system.environments <- + Imap.add model (pred k0) system.environments + | None -> () + +let add g = + begin + let bmap = + try Kfmap.find g.po_fun system.index + with Not_found -> Imap.empty + in + let bhv = match g.po_bhv with None -> "" | Some b -> b in + let pset = + try Imap.find bhv bmap + with Not_found -> WPOset.empty + in + if WPOset.mem g pset then + begin + let pi = ( g.po_model , WpPropId.property_of_id g.po_pid ) in + Hproof.remove system.proofs pi ; + Hpo.remove system.results g ; + end ; + let pset' = WPOset.add g pset in + let bmap' = Imap.add bhv pset' bmap in + system.index <- Kfmap.add g.po_fun bmap' system.index ; + end + +let set_po_result g r = + try + let pi = ( g.po_model , WpPropId.property_of_id g.po_pid ) in + let proof = + try Hproof.find system.proofs pi + with Not_found -> + let proof = WpAnnot.create_proof g.po_pid in + Hproof.add system.proofs pi proof ; proof + in + if r = Valid then WpAnnot.add_proof proof g.po_pid g.po_dep ; + let status = + if WpAnnot.is_proved proof then Property_status.True + else Property_status.Dont_know + in + let target = WpAnnot.target proof in + let depends = WpAnnot.dependencies proof in + Property_status.emit g.po_updater ~hyps:depends target status ; + with + ( [JS 2011/01/28] Please do not catch Log.* exception. Let the kernel do + the job ) + | Log.AbortFatal plugin as err -> + Wp_parameters.failure + "Update-status failed (problem in %s)" plugin ; + raise err + | err -> + Wp_parameters.failure + "Update-status failed (%s)" (Printexc.to_string err); + raise err + +let set_result g p r = + begin + let rs = + try Hpo.find system.results g + with Not_found -> + let rs = Results.create () in + Hpo.add system.results g rs ; rs + in + Results.replace rs p r ; + set_po_result g r ; + if p = WP then Wp_parameters.result "[WP:simplified] Goal %s : Valid" g.po_gid ; + end + +let get_result g p = + try Results.get (Hpo.find system.results g) p + with Not_found -> None + +let get_result = + Dynamic.register ~plugin:"Wp" "Wpo.get_result" ~journalize:false + (Datatype.func2 PODatatype.ty ProverType.ty + (Datatype.option ResultType.ty)) + get_result + +let is_valid = + Dynamic.register ~plugin:"Wp" "Wpo.is_valid" ~journalize:false + (Datatype.func ResultType.ty Datatype.bool) + (function Valid -> true | _ -> false) + + + +let get_results g = + try + let a = ref [] in + Results.iter (fun p r -> a:=(p,r)::!a) (Hpo.find system.results g) ; !a + with Not_found -> [] + +( -------------------------------------------------------------------------- ) +( --- Iterator --- ) +( -------------------------------------------------------------------------- ) + +let iter ?on_environment ?on_function ?on_behavior ?on_goal () = + begin + match on_environment with + | None -> () + | Some phi -> + Imap.iter + (fun m k -> + for i = 1 to k do + phi (env_name m i) + done) + system.environments + end ; + if on_function <> None || on_behavior <> None || on_goal <> None + then + let sorted_index = + List.sort + (fun (k1,_) (k2,_) -> + if Kernel_function.equal k1 k2 then 0 else + if Kernel_function.get_name k1 <= Kernel_function.get_name k2 + then -1 else 1) + (Kfmap.fold (fun k v a -> (k,v)::a) system.index []) + in + List.iter + (fun (kf,bmap) -> + if (on_behavior <> None || on_goal <> None) && + not (Imap.is_empty bmap) + then + begin + ( match on_function with + | None -> () + | Some phi -> phi kf ) ; + let sorted_behaviors = + List.sort + (fun (k1,_) (k2,_) -> String.compare k1 k2) + (Imap.fold (fun k v a -> (k,v)::a) bmap []) + in + List.iter + (fun (b,pset) -> + if not (WPOset.is_empty pset) then + begin + ( match on_behavior with + | None -> () + | Some phi -> + phi kf (if b="" then None else Some b) ) ; + match on_goal with + | None -> () + | Some f -> WPOset.iter f pset + end) + sorted_behaviors + end) + sorted_index + +let iter_on_goals = + Dynamic.register ~plugin:"Wp" "Wpo.iter_on_goals" + (Datatype.func (Datatype.func PODatatype.ty Datatype.unit) Datatype.unit) + ~journalize:true + (fun on_goal -> iter ~on_goal ()) + +( -------------------------------------------------------------------------- ) +( --- Prover and Files --- ) +( -------------------------------------------------------------------------- ) + +let local base suffix = + let dir = Wp_parameters.get_output () in + Printf.sprintf "%s/%s%s" dir base suffix + +let file_for_lang base lang = + let dir = Wp_parameters.get_output () in + let suffix = + match lang with + | L_altergo -> "_ergo.why" + | L_why -> ".why" + | L_coq -> ".v" + in Printf.sprintf "%s/%s%s" dir base suffix + +let file_for_ctxt ~env = local env ".txt" +let file_for_head ~gid = local gid "_head.txt" +let file_for_body ~gid = local gid "_body.txt" +let file_for_log_proof ~gid = function + | Why s -> local gid ("_" ^s^".txt") + | Coq -> local gid "_coq.txt" + | AltErgo -> local gid "_ergo.txt" + | WP -> local gid "_wp.txt" + +let file_for_log_proof_ = + Dynamic.register ~plugin:"Wp" "Wpo.file_for_log_proof" ~journalize:false + (Datatype.func2 + ~label1:("gid",None) Datatype.string ProverType.ty Datatype.string) + (fun gid p -> file_for_log_proof ~gid p) + +let file_for_log_check ~gid = function + | L_why -> local gid "_why.txt" + | L_coq -> local gid "_coq.txt" + | L_altergo -> local gid "_ergo.txt" + +let file_for_goal ~gid lang = file_for_lang gid lang +let file_for_env ~env lang = file_for_lang env lang +let file_for_po ~gid lang = file_for_lang (gid ^ "_po") lang + +let file_for_model ~model lang = + let dshare = Wp_parameters.get_share() in + let suffix = + match lang with + | L_altergo -> "_ergo.why" + | L_why -> "_model.why" + | L_coq -> "_model.v" + in Printf.sprintf "%s/%s%s" dshare model suffix + +let coq_for_env ~env = env +let coq_for_model ~model = model^"_model" +let coqc_for_model ~model = + let dir = Wp_parameters.get_output () in + Printf.sprintf "%s/%s_model.v" dir model + +let prover_of_name = function + | "" | "none" -> None + | "alt-ergo" -> Some AltErgo + | "coq" | "coqide" -> Some Coq + | s -> Some (Why s) + +let prover_of_name = + Dynamic.register ~plugin:"Wp" "Wpo.prover_of_name" ~journalize:false + (Datatype.func Datatype.string (Datatype.option ProverType.ty)) + prover_of_name + +let language_of_name = function + | "" | "none" -> None + | "alt-ergo" -> Some L_altergo + | "coq" | "coqide"-> Some L_coq + | "why" -> Some L_why + | s -> Wp_parameters.abort "Language '%s' unknown" s + +let language_of_prover = function + | Why _ -> L_why + | Coq -> L_coq + | AltErgo -> L_altergo + | WP -> L_why + + +let language_of_prover_name = function + | "" | "none" -> None + | "alt-ergo" -> Some L_altergo + | "coq" | "coqide" -> Some L_coq + | _ -> Some L_why + + +let is_interactive = function + | "coqide" -> true + | _ -> false + +let gui_provers = [ WP ; AltErgo ; Coq ; + Why "z3" ; Why "simplify" ; + Why "vampire"; + Why "cvc3" ; Why "yices" ; + Why "zenon" ] + + +( -------------------------------------------------------------------------- ) +( --- Proof Obligations : Pretty-printing --- ) +( -------------------------------------------------------------------------- ) + +let bar = String.make 60 '-' +let flow = ref false + +let pp_environment fmt env = + Format.fprintf fmt + "%s@\n Proof Environment %s@\n%s@\n@\n%a" + bar (String.capitalize env) bar + Command.pp_from_file (file_for_ctxt ~env) + +let pp_function fmt kf bhv = + flow := true ; + match bhv with + | None -> + Format.fprintf fmt + "%s@\n Function %s@\n%s@\n@\n" + bar (Kernel_function.get_name kf) bar + | Some bhv -> + Format.fprintf fmt + "%s@\n Function %s with behavior %s@\n%s@\n@\n" + bar (Kernel_function.get_name kf) bhv bar + +let pp_goal fmt g = + begin + Format.fprintf fmt "@[<v 0>Proof Obligation %s:@]@\n" g.po_name ; + List.iter + (fun (prover,result) -> + Format.fprintf fmt "Prover %a returns %a@\n" + pp_prover prover + pp_result result ; + ) (get_results g) ; + Format.fprintf fmt "Environment: %s@\n" (String.capitalize g.po_env) ; + List.iter (fun d -> Format.fprintf fmt "%a@\n" (pp_dependency g.po_fun) d) g.po_dep ; + List.iter (fun w -> Format.fprintf fmt "%a@\n" pp_warning w) g.po_warn ; + Format.fprintf fmt " + Proves %a@\n" (WpPropId.pretty_context g.po_fun) g.po_pid ; + Command.pp_from_file fmt (file_for_body ~gid:g.po_gid) + end + +let pp_goal_flow fmt g = + begin + if not !flow then Format.pp_print_newline fmt () ; + pp_goal fmt g ; + Format.fprintf fmt "@\n%s@." bar ; + flow := false ; + end + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpo.mli frama-c-20111001+nitrogen+dfsg/src/wp/wpo.mli --- frama-c-20110201+carbon+dfsg/src/wp/wpo.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpo.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,148 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ *) +(**{1 Proof Obligations} ) +( ------------------------------------------------------------------------ ) + +open Cil_types + +( Dynamically exported as ["Wpo.po"] ) +type t = +{ + po_fun : kernel_function ; ( function ) + po_bhv : string option ; ( behavior ) + po_pid : WpPropId.prop_id ; ( goal target property ) + po_gid : string ; ( goal identifier *) (** Uniquely Identify an object of type Wpo.t ) + po_env : string ; ( goal environment identifier ) + po_model : string ; ( model identifier ) + po_updater : Emitter.t ; ( property status updater ) + po_name : string ; ( goal informal name ) + po_dep : Property.t list ; ( dependencies ) + po_warn : warning list ; ( warnings *) +} + +and warning = { + wrn_loc : Lexing.position ; + wrn_severe : bool ; + wrn_source : string ; + wrn_reason : string ; + wrn_effect : string ; +} + +(** Dynamically exported. ) +type prover = + | Why of string ( Prover via WHY ) + | AltErgo ( Alt-Ergo ) + | Coq ( Coq and Coqide ) + | WP ( Simplifier *) + +type language = + | L_why + | L_coq + | L_altergo + +type result = + | Valid + | Invalid + | Unknown + | Timeout + | Computing + | Failed of string + +(** Dynamically exported + @since Nitrogen-20111001 +*) +val get_gid: t -> string + +val clear : unit -> unit + +val gid : context:string -> kf:kernel_function -> bhv:string option -> propid:WpPropId.prop_id -> string +val add : t -> unit +val new_env : context:string -> string (** Generates a fresh environment name. *) +val release_env : env:string -> unit (** Releases the last generated environment name. *) +val set_result : t -> prover -> result -> unit + +(** Dynamically exported. ) +val get_result : t -> prover -> result option +val get_results : t -> (prover result) list + +(** [true] if the result is valid. Dynamically exported. + @since Nitrogen-20111001 +*) +val is_valid: result -> bool + +val iter : + ?on_environment:(string -> unit) -> + ?on_function:(kernel_function -> unit) -> + ?on_behavior:(kernel_function -> string option -> unit) -> + ?on_goal:(t -> unit) -> + unit -> unit + +(** Dynamically exported. + @since Nitrogen-20111001 +*) +val iter_on_goals: (t -> unit) -> unit + +val bar : string +val pp_warning : Format.formatter -> warning -> unit +val pp_depend : Format.formatter -> Property.t -> unit +val pp_dependency : Kernel_function.t -> Format.formatter -> Property.t -> unit +val pp_goal : Format.formatter -> t -> unit +val pp_environment : Format.formatter -> string -> unit +val pp_prover : Format.formatter -> prover -> unit +val pp_result : Format.formatter -> result -> unit +val pp_language : Format.formatter -> language -> unit + +val pp_function : Format.formatter -> Kernel_function.t -> string option -> unit +val pp_goal_flow : Format.formatter -> t -> unit + +(** {2 File access for WPO} *) + +val file_for_ctxt : env:string -> string +val file_for_head : gid:string -> string +val file_for_body : gid:string -> string +(** Dynamically exported. *) +val file_for_log_proof : gid:string -> prover -> string +val file_for_log_check : gid:string -> language -> string +val file_for_po : gid:string -> language -> string +val file_for_goal : gid:string -> language -> string +val file_for_env : env:string -> language -> string +val file_for_model : model:string -> language -> string + +val coq_for_env: env:string -> string +val coq_for_model : model:string -> string +val coqc_for_model : model:string -> string + +val language_of_prover : prover -> language +val language_of_name : string -> language option +(** Dynamically exported. ) +val prover_of_name : string -> prover option +val language_of_prover_name: string -> language option +val is_interactive : string -> bool +val gui_provers : prover list + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wp_parameters.ml frama-c-20111001+nitrogen+dfsg/src/wp/wp_parameters.ml --- frama-c-20110201+carbon+dfsg/src/wp/wp_parameters.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wp_parameters.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,584 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +include Plugin.Register + (struct + let name = "WP" (* Format.sprintf "WP %s" Wp_version.version ) + let shortname = "wp" + let help = "Weakest Preconditions Calculus" ( v%d Wp_version.version ) + end) + +( localize all warnings inside WP ) + +let warning ?current = match current with + | None -> warning ~current:true + | Some b -> warning ~current:b + +let resetdemon = ref [] +let on_reset f = resetdemon := f :: !resetdemon +let reset () = List.iter (fun f -> f ()) !resetdemon + +module DebugKey = + StringList + (struct + let option_name = "-wp-log" + let arg_name = "..." + let help = "Undocumented feature" + let kind = `Irrelevant + end) +let () = DebugKey.add_set_hook (fun _old -> set_debug_keys) + +( ------------------------------------------------------------------------ ) +( --- WP Generation --- ) +( ------------------------------------------------------------------------ ) + +let wp_generation = add_group "Goal Selection" + +let () = Plugin.set_group wp_generation +let () = Plugin.do_not_save () +module WP = + Action(struct + let option_name = "-wp" + let help = "Computes wp on all functions." + let kind = `Tuning + end) +let () = on_reset WP.clear + +let () = Plugin.set_group wp_generation +let () = Plugin.do_not_save () +module Functions = + StringList + (struct + let option_name = "-wp-fct" + let arg_name = "f,..." + let help = "Computes wp only for the selected functions." + let kind = `Tuning + end) +let () = on_reset Functions.clear + +let () = Plugin.set_group wp_generation +let () = Plugin.do_not_save () +module Behaviors = + StringList + (struct + let option_name = "-wp-bhv" + let arg_name = "b,..." + let help = "Computes wp only for the selected behaviors." + let kind = `Tuning + end) +let () = on_reset Behaviors.clear + +let () = Plugin.set_group wp_generation +let () = Plugin.do_not_save () +module Properties = + ( TODO [LC] : restablish several names ) + StringList + (struct + let option_name = "-wp-prop" + let arg_name = "p" + let help = "Computes wp only for the selected properties.\n\ + Type 'assigns' for all assigns clauses" + let kind = `Tuning + end) +let () = on_reset Properties.clear + +type job = + | WP_None + | WP_All + | WP_Select of string list + +let job () = + match Functions.get (), Behaviors.get () with + | [], [] -> + (if WP.get () then WP_All + else match Properties.get () with + | [] -> WP_None + | _ :: _ -> WP_Select []) + | (_ :: _ as fct, _) | fct, _ :: _ -> WP_Select fct + +let () = Plugin.set_group wp_generation +module StatusAll = + False(struct + let option_name = "-wp-status-all" + let help = "Select properties with any status (default: no)" + let kind = `Tuning + end) + +let () = Plugin.set_group wp_generation +module StatusTrue = + False(struct + let option_name = "-wp-status-valid" + let help = "Select properties with status 'Valid' (default: no)" + let kind = `Tuning + end) + +let () = Plugin.set_group wp_generation +module StatusFalse = + False(struct + let option_name = "-wp-status-invalid" + let help = "Select properties with status 'Invalid' (default: no)" + let kind = `Tuning + end) + +let () = Plugin.set_group wp_generation +module StatusMaybe = + True(struct + let option_name = "-wp-status-maybe" + let help = "Select properties with status 'Maybe' (default: yes)" + let kind = `Tuning + end) + +( ------------------------------------------------------------------------ ) +( --- Froms --- ) +( ------------------------------------------------------------------------ ) + +let () = Plugin.set_group wp_generation +module Froms = + False(struct + let option_name = "-wp-froms" + let help = "Undocumented (dot not use)." + let kind = `Tuning + end) + +( ------------------------------------------------------------------------ ) +( --- Memory Models --- ) +( ------------------------------------------------------------------------ ) + +let wp_model = add_group "Model Selection" + +type model_kind = + | M_Hoare + | M_Store + | M_Runtime + +let model_names = + [ "Hoare" ; "Store"; "Runtime" ] + +let model_of_name = function + | "Runtime" -> M_Runtime + | "Store" -> M_Store + | "Hoare" -> M_Hoare + | _ -> raise Not_found + +let () = Plugin.set_group wp_model +module Model = + String(struct + let option_name = "-wp-model" + let arg_name = "model" + let help = + "Memory model selection:\n\ + - 'Hoare': no indirect access to the memory\n\ + - 'Store': no heterogeneous casts (default)\n\ + - 'Runtime': low-level model" + ( "- 'Runtime': low-level model\n\ + - 'UnsafeCaveat': no alias\n\ + - 'Caveat': no alias with guards" ) + let default = "Store" + let kind = `Tuning + end) +let () = Model.set_possible_values model_names + +let get_model () = + let m = Model.get () in + try model_of_name m + with Not_found -> abort "Unknown model '%s'" m + +let get_models () = model_names + +let () = Plugin.set_group wp_model +module LogicVar = + True(struct + let option_name = "-wp-logicvar" + let help = "Apply Hoare model for variables when possible." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_model +module RefVar = + False(struct + let option_name = "-wp-byreference" + let help = "Apply Hoare model for arguments passed by reference." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_model +module Assigns = + String(struct + let option_name = "-wp-assigns" + let arg_name = "mth" + let help = "Method for proving assigns clauses:\n\ + - 'effect' one sub-goal per assignment (default)\n\ + - 'memory' strong proof (incompatible with Hoare)\n\ + - 'none' skip assigns clause (default with Hoare)" + let default = "effect" + let kind = `Tuning + end) +let () = Assigns.set_possible_values [ "effect" ; "memory" ; "none" ] +( no reset for GUI ) + +let get_assigns_method () = + match Assigns.get () with + | "effect" -> Mcfg.EffectAssigns + | "memory" -> Mcfg.NormalAssigns + | "none" -> Mcfg.NoAssigns + | m -> abort "Unknown assigns method '%s'" m + +( ------------------------------------------------------------------------ ) +( --- WP Strategy --- ) +( ------------------------------------------------------------------------ ) + +let wp_strategy = add_group "Computation Strategies" + +let () = Plugin.set_group wp_strategy +module RTE = + False(struct + let option_name = "-wp-rte" + let help = "Generates RTE guards before WP" + let kind = `Tuning + end) + +let () = Plugin.set_group wp_strategy +module Simpl = + True(struct + let option_name = "-wp-simpl" + let help = "Simplify constant terms and predicates." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_strategy +module Invariants = + False(struct + let option_name = "-wp-invariants" + let help = "Handle generalized invariants inside loops." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_strategy +module Split = + False(struct + let option_name = "-wp-split" + let help = "Split conjunctions into sub-goals." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_strategy +module SplitDim = + Int(struct + let option_name = "-wp-split-dim" + let arg_name = "n" + let default = 6 + let help = + Printf.sprintf + "Bounds the number of splited sub-goals to 2n (default 2%d)" default + let kind = `Tuning + end) + +let () = Plugin.set_group wp_strategy +module Norm = + String(struct + let option_name = "-wp-norm" + let arg_name = "norm" + let help = + "Predicate normalization for Coq and Alt-Ergo provers:\n\ + - Eqs: replace let-bindings by equalities (default).\n\ + - Let: preserve let-bindings.\n\ + - Exp: let-expansion.\n\ + - Cc: generates local functions by closure-conversion" + let default = "Eqs" + let kind = `Tuning + end) + +let () = Norm.set_possible_values [ "Let";"Exp";"Cc";"Eqs" ] + +type norm = Let | Exp | Eqs | Cc + +let get_norm () = + match Norm.get () with + | "Let" -> Let + | "Exp" -> Exp + | "Eqs" -> Eqs + | "Cc" -> Cc + | m -> abort "Unknown normalization '%s'" m + +let () = Plugin.set_group wp_strategy +module Huge = + Int(struct + let option_name = "-wp-huge" + let default = 30 + let arg_name = "s" + let help = + Printf.sprintf + "Limits the size for generated proof obligation.\n\ + Proof terms of size exceeding 2^s are not generated.\n\ + (default: 2^%d)" + default + let kind = `Tuning + end) + +( ------------------------------------------------------------------------ ) +( --- Prover Interface --- ) +( ------------------------------------------------------------------------ ) + +let wp_prover = add_group "Prover Interface" + +let () = Plugin.set_group wp_prover +module Prover = + String(struct + let option_name = "-wp-proof" + let default = "alt-ergo" + let arg_name = "dp" + let help = + "Submit proof obligations to external prover:\n\ + - 'none' to skip proofs\n\ + Directly supported provers:\n\ + - 'alt-ergo' (default)\n\ + - 'coq', 'coqide' (see also -wp-script)\n\ + Supported provers via Why:\n\ + - 'simplify', 'vampire', 'yices', 'cvc3', 'z3', 'zenon'" + let kind = `Tuning + end) + +let prover_names = + [ "none" ; + "coq" ; "coqide" ; + "alt-ergo"; + "simplify"; + "vampire"; + "yices"; + "cvc3"; + "zenon"; + "z3" ] + +let () = Prover.set_possible_values prover_names +let get_provers () = prover_names + +let () = Plugin.set_group wp_prover +let () = Plugin.do_not_save () +module Check = + String(struct + let option_name = "-wp-check" + let default = "none" + let arg_name = "dp" + let help = + "Typecheck proof obligations for external prover:\n\ + - 'none' to skip checks (default)\n\ + - 'alt-ergo'\n\ + - 'coq'\n\ + - 'why' " + let kind = `Tuning + end) +let () = on_reset Check.clear + +let check_names = + [ "none" ; + "coq" ; + "alt-ergo"; + "why" ] + +let () = Plugin.set_group wp_prover +module Script = + String(struct + let option_name = "-wp-script" + let arg_name = "f.script" + let default = "" + let help = "Set user's file for saving Coq proofs." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_prover +module Timeout = + Int(struct + let option_name = "-wp-timeout" + let default = 10 + let arg_name = "n" + let help = + Printf.sprintf + "Set the timeout (in seconds) for provers (default: %d)." default + let kind = `Tuning + end) + +let () = Plugin.set_group wp_prover +module Procs = + Int(struct + let option_name = "-wp-par" + let arg_name = "p" + let default = 4 + let help = + Printf.sprintf + "Number of parallel proof process (default: %d)" default + let kind = `Tuning + end) + +let () = Plugin.set_group wp_prover +module Trace = + False(struct + let option_name = "-wp-trace" + let help = "Keep labels in proof obligations (default: no)." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_prover +module ShareDir = + String(struct + let option_name = "-wp-share" + let arg_name = "dir" + let default = "" + let help = "Directory where model specifications are found.\n\ + Defaults: installation directory $FRAMAC_SHARE/wp" + let kind = `Tuning + end) + +let () = Plugin.set_group wp_prover +module ProofTrace = + False + (struct + let option_name = "-wp-proof-trace" + let help = "Keeps output of provers for valid POs (default: no)" + let kind = `Tuning + end) + +( ------------------------------------------------------------------------ ) +( --- PO Management --- ) +( ------------------------------------------------------------------------ ) + +let wp_po = add_group "Proof Obligations" + +let () = Plugin.set_group wp_po +let () = Plugin.do_not_save () +module Print = + Action(struct + let option_name = "-wp-print" + let help = "Pretty-prints proof obligations on standard output." + let kind = `Tuning + end) +let () = on_reset Print.clear + +let () = Plugin.set_group wp_po +let () = Plugin.do_not_save () +module Dot = + False(struct + let option_name = "-wp-dot" + let help = "Generates dot files for wp computations." + let kind = `Tuning + end) +let () = on_reset Dot.clear + +let () = Plugin.set_group wp_po +module OutputDir = + String(struct + let option_name = "-wp-out" + let arg_name = "dir" + let default = "" + let help = "Set working directory for generated files.\n\ + Defaults to some temporary directory." + let kind = `Tuning + end) + +let () = Plugin.set_group wp_po +module Details = + False(struct + let option_name = "-wp-warnings" + let help = "Print details about warnings for 'stronger' and 'degenerated' goals" + let kind = `Tuning + end) + +( -------------------------------------------------------------------------- ) +( --- OS environment variables --- ) +( -------------------------------------------------------------------------- ) + +let get_env ?default var = + try + let varval = Sys.getenv var in + debug "ENV %s=%S" var varval ; varval + with Not_found -> + debug "ENV %s not set." var ; + match default with + | Some varval -> + debug "ENV %s default(%S)" var varval ; varval + | None -> + debug "ENV %s undefined." var ; + raise Not_found + +let is_out () = !Config.is_gui || OutputDir.get() <> "" + +(TODO: Projectifier cette reference) +let output_dir = ref None + +let make_output_dir dir = + if Sys.file_exists dir then + begin + if not (Sys.is_directory dir) then + abort "File '%s' is not a directory (WP aborted)" dir ; + dir + end + else + begin + try + Unix.mkdir dir 0o770 ; + debug "Created output directory '%s'" dir ; dir + with e -> + debug "System error '%s'" (Printexc.to_string e) ; + abort "Can not create output directory '%s'" dir + end + +let make_tmp_dir () = + begin + try Extlib.temp_dir_cleanup_at_exit "wp" + with Extlib.Temp_file_error s -> + abort "cannot create temporary file: %s" s + end + +let make_gui_dir () = + try + let home = try Sys.getenv "HOME" with Not_found -> "." in + make_output_dir (home ^ "/.frama-c-wp") + with _ -> + make_tmp_dir () + +let get_output () = + match !output_dir with + | Some dir -> dir + | None -> + let dir = + match OutputDir.get () with + | "" -> + if !Config.is_gui + then make_gui_dir () + else make_tmp_dir () + | dir -> + make_output_dir dir + in + output_dir := Some dir ; dir + +let get_share () = + match ShareDir.get() with + | "" -> Config.datadir^"/wp" + | dir -> + if Sys.file_exists dir && Sys.is_directory dir then dir + else abort "'%s': no such directory" dir + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wp_parameters.mli frama-c-20111001+nitrogen+dfsg/src/wp/wp_parameters.mli --- frama-c-20110201+carbon+dfsg/src/wp/wp_parameters.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wp_parameters.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,106 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +include Plugin.S + +val reset : unit -> unit + +( {2 Goal Selection} *) + +module WP : Plugin.Bool +module Functions : Plugin.String_list +module Behaviors : Plugin.String_list +module Properties : Plugin.String_list +module StatusAll : Plugin.Bool +module StatusTrue : Plugin.Bool +module StatusFalse : Plugin.Bool +module StatusMaybe : Plugin.Bool + +type job = + | WP_None + | WP_All + | WP_Select of string list + +val job : unit -> job + +(** {2 Model Selection} *) + +type model_kind = + | M_Hoare + | M_Store + | M_Runtime + +val get_model : unit -> model_kind +val get_models : unit -> string list +val get_assigns_method : unit -> Mcfg.assigns_method + +module Model : Plugin.String +module LogicVar : Plugin.Bool +module RefVar : Plugin.Bool +module Assigns : Plugin.String + +(** {2 Computation Strategies} *) + +type norm = Let | Exp | Eqs | Cc +val get_norm : unit -> norm + +module RTE: Plugin.Bool +module Simpl: Plugin.Bool +module Split: Plugin.Bool +module Invariants: Plugin.Bool +module SplitDim: Plugin.Int +module Norm: Plugin.String +module Huge: Plugin.Int + +(** {2 Prover Interface} *) + +module Prover: Plugin.String +module Check : Plugin.String +module Script : Plugin.String +module Timeout: Plugin.Int +module Procs: Plugin.Int +module Trace: Plugin.Bool +module ProofTrace: Plugin.Bool + +(** {2 Proof Obligations} *) + +module Dot: Plugin.Bool +module Print: Plugin.Bool +module Details: Plugin.Bool + +(** {2 Experimental} *) + +module Froms: Plugin.Bool + +(** {2 Environment Variables} ) + +val get_env : ?default:string -> string -> string +val is_out : unit -> bool ( -wp-out <dir> positionned ) +val get_output : unit -> string +val get_share : unit -> string + + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpPropId.ml frama-c-20111001+nitrogen+dfsg/src/wp/wpPropId.ml --- frama-c-20110201+carbon+dfsg/src/wp/wpPropId.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpPropId.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,622 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types +open Cil_datatype + +(----------------------------------------------------------------------------) +(* Property identification ) +(----------------------------------------------------------------------------*) + +(** Beside the property identification, it can be found in different contexts + * depending on which part of the computation is involved. + * For instance, properties on loops are split in 2 parts : establishment and + * preservation. + *) + +type prop_kind = + | PKProp (** normal property *) + | PKEstablished (** computation related to a loop property before the loop. *) + | PKPreserved (** computation related to a loop property inside the loop. *) + | PKPropLoop (** loop property used as hypothesis inside a loop. *) + | PKVarDecr (** computation related to the decreasing of a variant in a loop *) + | PKVarPos (** computation related to a loop variant being positive *) + | PKAFctOut (** computation related to the function assigns on normal termination *) + | PKAFctExit (** computation related to the function assigns on exit termination ) + | PKPre of kernel_function stmt * Property.t (** precondition for function + at stmt, property of the require. Many information that should come + from the p_prop part of the prop_id, but in the PKPre case, + it seems that it is hiden in a IPBlob property ! ) + +type prop_id = { + p_kind : prop_kind ; + p_prop : Property.t ; + p_part : (int int) option ; +} + +let parts_of_id p = p.p_part +let mk_part pid (k, n) = { pid with p_part = Some (k,n) } +let property_of_id p = p.p_prop + +exception Found of int +let num_of_bhv_from bhv (out, _) = + match bhv.b_assigns with + WritesAny -> Wp_parameters.fatal "no \\from in this behavior ???" + | Writes l -> + let add n (o, f) = match f with FromAny -> n + | From _ -> + if Logic_utils.is_same_identified_term out o then + raise (Found n) + else n+1 + in + try + let _ = List.fold_left add 1 l in + Wp_parameters.fatal "didn't found this \\from" + with Found n -> n + +(----------------------------------------------------------------------------) +(* Constructors ) +(----------------------------------------------------------------------------) + +let mk_annot_id kf stmt ca = Property.ip_of_code_annot_single kf stmt ca + +let mk_prop kind prop = { p_kind=kind ; p_prop=prop ; p_part=None } + +let mk_code_annot_id kf s ca = mk_prop PKProp (mk_annot_id kf s ca) +let mk_assert_id kf s ca = mk_prop PKProp (mk_annot_id kf s ca) +let mk_establish_id kf s ca = mk_prop PKEstablished (mk_annot_id kf s ca) +let mk_preserve_id kf s ca = mk_prop PKPreserved (mk_annot_id kf s ca) +let mk_inv_hyp_id kf s ca = mk_prop PKPropLoop (mk_annot_id kf s ca) +let mk_var_decr_id kf s ca = mk_prop PKVarDecr (mk_annot_id kf s ca) +let mk_var_pos_id kf s ca = mk_prop PKVarPos (mk_annot_id kf s ca) + +let mk_loop_from_id kf s ca from = + let id = Property.ip_of_from kf (Kstmt s) (Property.Id_code_annot ca) from in + mk_prop PKPropLoop id + +let mk_bhv_from_id kf ki bhv from = + let id = Property.ip_of_from kf ki (Property.Id_behavior bhv) from in + mk_prop PKProp id + +let get_kind_for_tk kf tkind = match tkind with + | Normal -> + if Cil2cfg.has_exit (Cil2cfg.get kf) then PKAFctOut else PKProp + | Exits -> PKAFctExit + | _ -> assert false + +let mk_fct_from_id kf bhv tkind from = + let id = Property.ip_of_from kf Kglobal (Property.Id_behavior bhv) from in + let kind = get_kind_for_tk kf tkind in + mk_prop kind id + +let mk_disj_bhv_id (kf,ki,disj) = + mk_prop PKProp (Property.ip_of_disjoint kf ki disj) +let mk_compl_bhv_id (kf,ki,comp) = + mk_prop PKProp (Property.ip_of_complete kf ki comp) +let mk_decrease_id (kf, s, x) = + mk_prop PKProp (Property.ip_of_decreases kf s x) + +let mk_axiom_id name = mk_prop PKProp (Property.ip_axiom name) + +let mk_stmt_assigns_id kf s b a = + let b = Property.Id_behavior b in + let p = Property.ip_of_assigns kf (Kstmt s) b (Writes a) in + Extlib.opt_map (mk_prop PKProp) p + +let mk_loop_assigns_id kf s ca a = + let ca = Property.Id_code_annot ca in + let p = Property.ip_of_assigns kf (Kstmt s) ca (Writes a) in + Extlib.opt_map (mk_prop PKPropLoop) p + +let mk_fct_assigns_id kf b tkind a = + let b = Property.Id_behavior b in + let kind = get_kind_for_tk kf tkind in + let p = Property.ip_of_assigns kf Kglobal b (Writes a) in + Extlib.opt_map (mk_prop kind) p + +let mk_pre_id kf ki b p = + mk_prop PKProp (Property.ip_of_requires kf ki b p) + +let mk_stmt_post_id kf s b p = + mk_prop PKProp (Property.ip_of_ensures kf (Kstmt s) b p) + +let mk_fct_post_id kf b p = + mk_prop PKProp (Property.ip_of_ensures kf Kglobal b p) + +let mk_call_pre_id called_kf s_call called_pre called_pre_p = + let kind = PKPre (called_kf, s_call, called_pre) in + mk_prop kind called_pre_p + +(----------------------------------------------------------------------------) + +module Prop_id_datatype = + Datatype.Make( + struct + type t = prop_id + include Datatype.Undefined + let name = "WpAnnot.prop_id" + let reprs = + List.map + (fun x -> { p_kind = PKProp; p_prop = x; p_part = None }) + Property.reprs + end) + + + + +(----------------------------------------------------------------------------) +( Names and Printing ) +( [JS 2011/08/04] This stuff seems to be related only to Property.t. + Maybe better to put it in a kernel-friendly way somewhere in module + [Property]? ) +(----------------------------------------------------------------------------) + +let pp_names fmt l = match l with [] -> () + | _ -> + Format.fprintf fmt "_%a" (Wp_error.pp_string_list ~empty:"" ~sep:"_") l + +let code_annot_names ca = match ca.annot_content with + | AAssert (_, named_pred) | AInvariant (_,_,named_pred) -> named_pred.name + | AVariant (term, _) -> term.term_name + | _ -> [] ( TODO : add some more names ? *) + +(** This is used to give the name of the property that the user can give + * to select it from the command line (-wp-prop option) ) +let user_prop_names p = match p with + | Property.IPPredicate (_,_,_,idp) -> idp.ip_name + | Property.IPCodeAnnot (_,_, ca) -> code_annot_names ca + | Property.IPComplete (_, _, lb) -> + let name = + Pretty_utils.sfprintf "complete_behaviors%a" pp_names lb + in [name] + | Property.IPDisjoint (_, _, lb) -> + let name = Pretty_utils.sfprintf "disjoint_behaviors%a" pp_names lb + in [name] + | Property.IPAssigns (_, _, _, l) -> + List.fold_left + (fun acc (t,_) -> t.it_content.term_name @ acc) ["assigns"] l + | Property.IPFrom _ -> ["from"] ( TODO: steal term names from assigns? ) + | Property.IPDecrease (_,_, Some ca,_) -> code_annot_names ca + | Property.IPDecrease _ -> ["decreases"](TODO: add more names ? ) + | Property.IPAxiom _ + | Property.IPAxiomatic _ + | Property.IPLemma _ + | Property.IPBehavior _ + | Property.IPUnreachable _ + | Property.IPOther _ -> [] + +let string_of_termination_kind = function + Normal -> "post" + | Exits -> "exits" + | Breaks -> "breaks" + | Continues -> "continues" + | Returns -> "returns" + +let predicate_kind_txt pk ki = match pk, ki with + | Property.PKRequires _, Kglobal -> "pre" + | Property.PKRequires _, Kstmt _ -> "stmt_pre" + | Property.PKAssumes _, _ -> "assume" + | Property.PKEnsures (_, tk), Kglobal -> + string_of_termination_kind tk + | Property.PKEnsures (_, tk), Kstmt _ -> + "stmt_" ^ (string_of_termination_kind tk) + | Property.PKTerminates, _ -> "terminates" + +let id_prop_txt p = match p with + | Property.IPPredicate (pk,_,ki,idp) -> + Pretty_utils.sfprintf "%s_%d%a" + (predicate_kind_txt pk ki) idp.ip_id pp_names idp.ip_name + | Property.IPCodeAnnot (_,_, ca) -> + let name = match ca.annot_content with + | AAssert _ -> "assert" + | AInvariant _ -> "loop_inv" + | APragma _ -> "code_annot" + | _ -> assert false + in Pretty_utils.sfprintf "%s_%d%a" name ca.annot_id + pp_names (code_annot_names ca) + | Property.IPComplete (_, _, lb) -> + Pretty_utils.sfprintf "complete_behaviors%a" pp_names lb + | Property.IPDisjoint (_, _, lb) -> + Pretty_utils.sfprintf "disjoint_behaviors%a" pp_names lb + | Property.IPDecrease (_,_,None,_) -> "decreases" + | Property.IPDecrease _ -> "loop_variant" + | Property.IPAxiom name -> "axiom_" ^ name + | Property.IPAxiomatic(name, _) -> "axiomatic_" ^ name + | Property.IPLemma name -> "lemma_" ^ name + | Property.IPAssigns (_kf, ki, _bhv, _) -> + let name = match ki with + | Kglobal -> "function_assigns" + | Kstmt s -> + match s.skind with + | Loop _ -> "loop_assigns_" ^ string_of_int s.sid + | _ -> "stmt_assigns_" ^ string_of_int s.sid + in name + | Property.IPFrom (_, _, _, (out,_)) -> + "from_id_"^(string_of_int (out.it_id)) + | Property.IPUnreachable _ -> "unreachable stmt" + | Property.IPBehavior(_, _, b) -> b.b_name + | Property.IPOther(s,_,_) -> s + +let name_of_prop_id p = match p.p_kind , p.p_prop with + | PKProp , Property.IPAssigns (_kf, (Kstmt s), _, _) -> + "stmt_assigns_" ^ string_of_int s.sid + | PKProp , p -> id_prop_txt p + | PKPropLoop , Property.IPAssigns (_kf, (Kstmt s), _, _) -> + "loop_assigns_" ^ string_of_int s.sid + | PKPropLoop , p -> id_prop_txt p + | PKEstablished , p -> id_prop_txt p ^ "_established" + | PKPreserved , p -> id_prop_txt p ^ "_preserved" + | PKVarDecr , p -> id_prop_txt p ^ "_decrease" + | PKVarPos , p -> id_prop_txt p ^ "_positive" + | PKAFctOut , Property.IPFrom _ -> "normal_from" + | PKAFctExit , Property.IPFrom _ -> "exit_from" + | PKAFctOut , _ -> "normal_assigns" + | PKAFctExit , _ -> "exit_assigns" + | PKPre(kf,stmt,p) , _ -> + let pid = match p with + | Property.IPCodeAnnot(_,_,p) -> p.annot_id + | Property.IPPredicate(_,_,_,p) -> p.ip_id + | property -> Wp_parameters.fatal "No precondition id for @[%a@]" + Property.pretty property + in + Printf.sprintf "pre%d_%s_s%d" pid (Kernel_function.get_name kf) stmt.sid + +let prop_id_name p = match p.p_part with + | None -> name_of_prop_id p + | Some(k,_) -> Printf.sprintf "%s_part%d" (name_of_prop_id p) (succ k) + +let label_of_kind = function + | PKProp -> "Property" + | PKPropLoop -> "Invariant" ( should be assert false ??? ) + | PKEstablished -> "Establishment" + | PKPreserved -> "Preservation" + | PKVarDecr -> "Decreasing" + | PKVarPos -> "Positive" + | PKAFctOut -> "Function assigns" + | PKAFctExit -> "Exit assigns" + | PKPre(kf,_,_) -> + Printf.sprintf "Precondition for '%s'" (Kernel_function.get_name kf) + +let label_of_prop_id p = + match p.p_part with + | None -> label_of_kind p.p_kind + | Some(k,n) -> + Printf.sprintf "%s (%d/%d)" (label_of_kind p.p_kind) (succ k) n + +let pp_id_name fmt pid = Format.fprintf fmt "%s" (prop_id_name pid) + +(----------------------------------------------------------------------------) +( Pretty-Print ) +(----------------------------------------------------------------------------) + +let pp_goal_kind fmt = function + | PKProp + | PKPropLoop + | PKAFctOut + | PKAFctExit + | PKPre _ -> () + | PKEstablished -> Format.pp_print_string fmt "Establishment of " + | PKPreserved -> Format.pp_print_string fmt "Preservation of " + | PKVarDecr -> Format.pp_print_string fmt "Decreasing of " + | PKVarPos -> Format.pp_print_string fmt "Positivity of " + +let pp_goal_part fmt = function + | None -> () + | Some(k,n) -> Format.fprintf fmt " (%d/%d)" (succ k) n + +let pretty fmt pid = + begin + pp_goal_kind fmt pid.p_kind ; + Description.pp_property fmt pid.p_prop ; + pp_goal_part fmt pid.p_part ; + end + +let pretty_context kf fmt pid = + begin + pp_goal_kind fmt pid.p_kind ; + Description.pp_localized ~kf:(`Context kf) ~ki:true fmt pid.p_prop ; + pp_goal_part fmt pid.p_part ; + end + +(----------------------------------------------------------------------------) +( Comparison ) +(----------------------------------------------------------------------------) + +let kind_order = function + | PKProp -> 0 + | PKPre _ -> 0 + | PKEstablished -> 1 + | PKPreserved -> 2 + | PKVarPos -> 3 + | PKVarDecr -> 4 + | PKPropLoop -> 5 + | PKAFctOut -> 6 + | PKAFctExit -> 7 + +let compare_prop_id pid1 pid2 = + ( This order of compatison groups together prop_pids with same properties ) + let p1 = property_of_id pid1 in + let p2 = property_of_id pid2 in + let cmp = Property.compare p1 p2 in + if cmp <> 0 then cmp + else + let cmp = kind_order pid2.p_kind - kind_order pid1.p_kind in + if cmp <> 0 then cmp + else + Pervasives.compare pid1.p_part pid2.p_part + +let is_assigns p = + match property_of_id p with + | Property.IPAssigns _ -> true + | _ -> false + +let is_requires = function + | Property.IPPredicate (Property.PKRequires _,_,_,_) -> true + | _ -> false + +let select_by_name asked pid = + let p_prop = match pid.p_kind with + | PKPre (_,_,p_prop) -> p_prop + | _ -> property_of_id pid + in + let names = user_prop_names p_prop in + let take_it, msg = + if List.mem asked names + then true, " (asked named prop)" + else false, (match names with [] -> " (no names)" + | name::_ -> (" (asked name <> "^ name^")")) + in take_it, msg + +let select_call_pre s_call asked_pre pid = + let take_it, msg = match pid.p_kind with + | PKPre (_, p_stmt, p_prop) -> + if Stmt.equal s_call p_stmt then + let x = match asked_pre with + | None -> true, "" + | Some asked_pre -> + if Property.equal p_prop asked_pre then true, "" + else false, " (stmt ok, but not not the asked pre)" + in x + else false, " (not the asked stmt)" + | _ -> false, " (not a call pre)" + in take_it, msg + + +(----------------------------------------------------------------------------) +( About assigns identification ) +(----------------------------------------------------------------------------*) + +(** TODO: it seems that this type is not used anymore... ) +type a_fun = Assigns_FctOut | Assigns_FctExit | Assigns_Stmt | Assigns_Loop + +type a_kind = LoopAssigns | StmtAssigns + +type assigns_desc = { + a_label : Cil_types.logic_label ; + ( a_fun : a_fun ; ) + a_kind : a_kind ; + a_assigns : Cil_types.identified_term Cil_types.assigns ; +} + +let mk_loop_assigns_desc s assigns = { + a_label = Clabels.mk_logic_label s ; + ( a_fun = Assigns_Loop ; ) + a_kind = LoopAssigns ; + a_assigns = Writes assigns +} + +let mk_stmt_assigns_desc s assigns = { + a_label = Clabels.mk_logic_label s ; + ( a_fun = Assigns_Stmt ; ) + a_kind = StmtAssigns ; + a_assigns = Writes assigns ; +} + +( +(** kf assigns for normal path when there is an exit path ) +let mk_fout_assigns_desc assigns = { + a_label = Logic_const.pre_label ; + ( a_fun = Assigns_FctOut ; *) + a_kind = StmtAssigns ; + a_assigns = Writes assigns ; +} + +(** kf assigns for exit path ) +let mk_exit_assigns_desc assigns = { + a_label = Logic_const.pre_label ; + ( a_fun = Assigns_FctExit ; ) + a_kind = StmtAssigns ; + a_assigns = Writes assigns ; +} +) + +let mk_kf_assigns_desc assigns = { + a_label = Logic_const.pre_label ; + (* a_fun = Assigns_Stmt ; ) + a_kind = StmtAssigns ; + a_assigns = Writes assigns ; +} + +let pp_assigns_desc fmt a = Wp_error.pp_assigns fmt a.a_assigns +(----------------------------------------------------------------------------*) +(** + * 2 kinds of annotations can be found : predicates and assigns. + * because assigns properties can only be translated into predicates + * by the memory model. + * - Assigns properties are composed of the assigns list from Cil, + * and a label to know where to stop. + * - Predicates are just the predicate type from Cil. + ) +(----------------------------------------------------------------------------) + +type pred_info = prop_id Cil_types.predicate named + +let mk_pred_info id p = (id, p) +let pred_info_id (id, _) = id +let pp_pred_of_pred_info fmt (_id, p) = !Ast_printer.d_predicate_named fmt p +let pp_pred_info fmt (id, p) = + Format.fprintf fmt "(@[%a:@ %a@])" pp_id_name id !Ast_printer.d_predicate_named p + +type assigns_info = prop_id * assigns_desc + +let assigns_info_id (id,_) = id + +type assigns_full_info = + AssignsLocations of assigns_info + | AssignsAny of assigns_desc + | NoAssignsInfo + +let empty_assigns_info = NoAssignsInfo +let mk_assigns_info id a = AssignsLocations (id, a) + +let mk_stmt_any_assigns_info s = + let a = { a_label = Clabels.mk_logic_label s; (* a_fun = Assigns_Stmt; ) + a_kind = StmtAssigns; a_assigns = WritesAny } in + AssignsAny a + +let mk_kf_any_assigns_info () = + let a = { a_label = Logic_const.pre_label; ( a_fun = Assigns_Stmt; ) + a_kind = StmtAssigns; a_assigns = WritesAny } in + AssignsAny a + +let mk_loop_any_assigns_info s = + let a = { a_label = Clabels.mk_logic_label s; ( a_fun = Assigns_Loop; ) + a_kind = LoopAssigns; a_assigns = WritesAny } in + AssignsAny a + +let pp_assigns_id (id, _a) = pp_id_name id + +let pp_assign_info k fmt a = match a with + | NoAssignsInfo -> () + | AssignsAny a -> + let pkind = + match a.a_kind with + | StmtAssigns -> "" + | LoopAssigns -> "loop" + in + Format.fprintf fmt "%s(@@%a): %s assigns everything@." + k Wp_error.pp_logic_label a.a_label pkind + | AssignsLocations (_,a) -> Format.fprintf fmt "%s(@@%a): %a@." k + Wp_error.pp_logic_label a.a_label + pp_assigns_desc a + +let merge_assign_info a1 a2 = match a1,a2 with + | NoAssignsInfo, a | a, NoAssignsInfo -> a + | (AssignsLocations _ | AssignsAny _), + (AssignsLocations _ | AssignsAny _) -> + Wp_parameters.fatal "Several assigns ?" + + +type t_axiom = string Cil_types.logic_label list * Cil_types.predicate named +type axiom_info = prop_id * t_axiom + +let mk_axiom_info name labels p = + let id = mk_axiom_id name in (id, (name, labels, p)) + +let pp_axiom_info fmt (id, (_name, _labels, p)) = + Format.fprintf fmt "(@[%a:@ %a@])" pp_id_name id !Ast_printer.d_predicate_named p + +(----------------------------------------------------------------------------) +(** About proofs ) +(----------------------------------------------------------------------------) +let subproofs id = match id.p_kind with + | PKProp | PKPre _ | PKPropLoop -> 1 + | PKEstablished | PKPreserved + | PKVarDecr | PKVarPos + | PKAFctExit | PKAFctOut -> 2 + +let subproof_idx id = match id.p_kind with + | PKProp | PKPre _ | PKPropLoop -> 0 ( 1/1 ) + | PKPreserved -> 0 ( 1/2 ) + | PKEstablished-> 1 ( 2/2 ) + | PKVarDecr -> 0 ( 1/2 ) + | PKVarPos -> 1 ( 2/2 ) + | PKAFctOut -> 0 ( 1/2 ) + | PKAFctExit -> 1 ( 2/2 *) +(** find the outer loop in which the stmt is. ) +let get_loop_stmt kf stmt = + ( because we don't have the cfg here, we can only use Cil information, + * and then we can only recognize syntactic loops... TODO: use the cfg ? *) + let rec is_in_blk b = List.exists is_in_stmt b.bstmts + and is_in_stmt s = if s.sid = stmt.sid then true + else match s.skind with + | If (_, b1, b2,_) -> is_in_blk b1 || is_in_blk b2 + | Switch (_, b, _, _) | Block b -> is_in_blk b + | UnspecifiedSequence seq -> + let b = Cil.block_from_unspecified_sequence seq in + is_in_blk b + | Loop (_, b, _, _, _) -> is_in_blk b + | _ -> false + and find_loop_in_blk blk = find_loop_in_stmts blk.bstmts + and find_loop_in_stmts l = match l with + | [] -> None + | s::tl -> + (match find_loop_in_stmt s with Some l -> Some l + | None -> find_loop_in_stmts tl) + and find_loop_in_stmt s = match s.skind with + | (Loop _) -> if is_in_stmt s then Some s else None + | If (_, b1, b2,_) -> + (match find_loop_in_blk b1 with Some l -> Some l + | None -> find_loop_in_blk b2) + | Switch (_, b, _, _) | Block b -> find_loop_in_blk b + | UnspecifiedSequence seq -> + let b = Cil.block_from_unspecified_sequence seq in + find_loop_in_blk b + | _ -> None + in let f = Kernel_function.get_definition kf in + find_loop_in_blk f.sbody + +(** Quite don't understand what is going on here... what is it supposed to do ? +* [2011-07-07-Anne] ) +let get_induction p = + let get_stmt = function + | Property.IPDecrease(kf,Kstmt stmt,_,_) -> Some (kf, stmt) + | Property.IPCodeAnnot(kf,stmt,_) -> Some (kf, stmt) + | Property.IPAssigns(kf,Kstmt stmt,_,_) -> Some (kf, stmt) + | _ -> None + in match p.p_kind with + | PKAFctOut|PKAFctExit|PKPre _ -> None + | PKProp -> + let loop_stmt_opt = match get_stmt (property_of_id p) with + | None -> None + | Some (kf, s) -> get_loop_stmt kf s + in loop_stmt_opt + | PKPropLoop -> + let loop_stmt_opt = match property_of_id p with + | Property.IPCodeAnnot(kf,stmt, + {annot_content = AInvariant(_, loop, _)}) + -> + if loop then (loop invariant ) Some stmt + else ( invariant inside loop ) get_loop_stmt kf stmt + | Property.IPAssigns (_, Kstmt stmt, Property.Id_code_annot _, _) -> + ( loop assigns ) Some stmt + | _ -> None ( assert false ??? ) + in loop_stmt_opt + | PKEstablished|PKVarDecr|PKVarPos|PKPreserved -> + (match get_stmt (property_of_id p) with + | None -> None | Some (_, s) -> Some s) + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpPropId.mli frama-c-20111001+nitrogen+dfsg/src/wp/wpPropId.mli --- frama-c-20110201+carbon+dfsg/src/wp/wpPropId.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpPropId.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,213 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(************************************************************************) + +open Cil_types + +( Beside the property identification, it can be found in different contexts + * depending on which part of the computation is involved. + * For instance, properties on loops are split in 2 parts : establishment and + * preservation. + *) + +(** Property.t information and kind of PO (establishment, preservation, etc) *) +type prop_id + +(** returns the annotation which lead to the given PO. + Dynamically exported. + ) +val property_of_id : prop_id -> Property.t + +(----------------------------------------------------------------------------) + +module Prop_id_datatype: Datatype.S with type t = prop_id + +(----------------------------------------------------------------------------*) + +val compare_prop_id : prop_id -> prop_id -> int + +val is_assigns : prop_id -> bool +val is_requires : Property.t -> bool + +(** test if the prop_id has to be selected for the asked name. +* Also returns a debug message to explain then answer. ) +val select_by_name : string -> prop_id -> bool string + +(** test if the prop_id has to be selected when we want to select the call +* precondition the the [stmt] call (None means all the call preconditions). +* Also returns a debug message to explain then answer. ) +val select_call_pre : stmt -> Property.t option -> prop_id -> bool string + +(----------------------------------------------------------------------------) + +val prop_id_name : prop_id -> string +val pp_id_name : Format.formatter -> prop_id -> unit + +val pretty : Format.formatter -> prop_id -> unit +val pretty_context : Kernel_function.t -> Format.formatter -> prop_id -> unit + +(** Short description of the kind of PO *) +val label_of_prop_id: prop_id -> string + +(** Short description of the PO *) +val name_of_prop_id: prop_id -> string + +(** TODO: this one should be in Properties_status. *) +val id_prop_txt : Property.t -> string + +(** TODO: should probably be somewhere else ) +val string_of_termination_kind : termination_kind -> string + +val num_of_bhv_from : funbehavior -> identified_term from -> int +(----------------------------------------------------------------------------*) + +val mk_code_annot_id : kernel_function -> stmt -> code_annotation -> prop_id + +val mk_assert_id : kernel_function -> stmt -> code_annotation -> prop_id + +(** Invariant establishment *) +val mk_establish_id : kernel_function -> stmt -> code_annotation -> prop_id + +(** Invariant preservation *) +val mk_preserve_id : kernel_function -> stmt -> code_annotation -> prop_id + +(** Invariant used as hypothesis *) +val mk_inv_hyp_id : kernel_function -> stmt -> code_annotation -> prop_id + +(** Variant decrease *) +val mk_var_decr_id : kernel_function -> stmt -> code_annotation -> prop_id + +(** Variant positive *) +val mk_var_pos_id : kernel_function -> stmt -> code_annotation -> prop_id + +(** \from property of loop assigns *) +val mk_loop_from_id : kernel_function -> stmt -> code_annotation -> + identified_term from -> prop_id + +(** \from property of function or statement behavior assigns *) +val mk_bhv_from_id : kernel_function -> kinstr -> funbehavior -> + identified_term from -> prop_id + +val mk_fct_from_id : kernel_function -> funbehavior -> + termination_kind -> identified_term from -> prop_id + +(** disjoint behaviors property. ) +val mk_disj_bhv_id : kernel_function kinstr * string list -> prop_id + +(** complete behaviors property. ) +val mk_compl_bhv_id : kernel_function kinstr * string list -> prop_id + +val mk_decrease_id : kernel_function * kinstr * term variant -> prop_id + +(** axiom identification *) +val mk_axiom_id : string -> prop_id + +val mk_stmt_assigns_id : kernel_function -> stmt -> funbehavior -> + identified_term from list -> prop_id option + +val mk_loop_assigns_id : kernel_function -> stmt -> code_annotation -> + identified_term from list -> prop_id option + +(** function assigns ) +val mk_fct_assigns_id : kernel_function -> funbehavior -> + termination_kind -> identified_term from list -> prop_id option + +val mk_pre_id : kernel_function -> kinstr -> funbehavior -> + identified_predicate -> prop_id + +val mk_stmt_post_id : kernel_function -> stmt -> funbehavior -> + termination_kind identified_predicate -> prop_id + +val mk_fct_post_id : kernel_function -> funbehavior -> + termination_kind * identified_predicate -> prop_id + +(** [mk_call_pre_id called_kf s_call called_pre] ) +val mk_call_pre_id : kernel_function -> stmt -> + Property.t -> Property.t -> prop_id + +(----------------------------------------------------------------------------) + +type a_kind = LoopAssigns | StmtAssigns +type assigns_desc = private { + a_label : Cil_types.logic_label ; + a_kind : a_kind ; + a_assigns : Cil_types.identified_term Cil_types.assigns ; +} +val pp_assigns_desc : Format.formatter -> assigns_desc -> unit + +type assigns_info = prop_id assigns_desc +val assigns_info_id : assigns_info -> prop_id + +type assigns_full_info = private + AssignsLocations of assigns_info + | AssignsAny of assigns_desc + | NoAssignsInfo + +val empty_assigns_info : assigns_full_info +val mk_assigns_info : prop_id -> assigns_desc -> assigns_full_info +val mk_stmt_any_assigns_info : stmt -> assigns_full_info +val mk_kf_any_assigns_info : unit -> assigns_full_info +val mk_loop_any_assigns_info : stmt -> assigns_full_info + +val pp_assign_info : string -> Format.formatter -> assigns_full_info -> unit +val merge_assign_info : + assigns_full_info -> assigns_full_info -> assigns_full_info + +val mk_loop_assigns_desc : stmt -> identified_term from list -> assigns_desc + +val mk_stmt_assigns_desc : stmt -> identified_term from list -> assigns_desc + +val mk_kf_assigns_desc : identified_term from list -> assigns_desc + +(----------------------------------------------------------------------------) + +type t_axiom = string * Cil_types.logic_label list * Cil_types.predicate named +type axiom_info = prop_id * t_axiom + +val mk_axiom_info : + string -> Cil_types.logic_label list -> Cil_types.predicate named -> axiom_info +val pp_axiom_info : Format.formatter -> axiom_info -> unit + +type pred_info = (prop_id * Cil_types.predicate named) + +val mk_pred_info : prop_id -> Cil_types.predicate named -> pred_info +val pred_info_id : pred_info -> prop_id +val pp_pred_of_pred_info : Format.formatter -> pred_info -> unit +val pp_pred_info : Format.formatter -> pred_info -> unit + +(----------------------------------------------------------------------------) + +(** [mk_part pid (k, n)] build the identification for the [k/n] part of [pid].) +val mk_part : prop_id -> (int int) -> prop_id + +(** get the 'part' infomation. ) +val parts_of_id : prop_id -> (int int) option + +(** How many subproofs *) +val subproofs : prop_id -> int + +(** subproof index of this propr_id ) +val subproof_idx : prop_id -> int + +val get_induction : prop_id -> stmt option + +(----------------------------------------------------------------------------*) + diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wprop.ml frama-c-20111001+nitrogen+dfsg/src/wp/wprop.ml --- frama-c-20110201+carbon+dfsg/src/wp/wprop.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wprop.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,133 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* -------------------------------------------------------------------------- ) +( --- WP Internal State --- ) +( -------------------------------------------------------------------------- ) + +module WP = State_builder.Ref + (Datatype.Unit) + (struct + let name = "WP" + let kind = `Internal + let dependencies = [Ast.self] + let default () = () + end) + +( -------------------------------------------------------------------------- ) +( --- Indexed Interface --- ) +( -------------------------------------------------------------------------- ) + +type property = + | Later of Property.t + | Proxy of Property.t Emitter.t * Property.t list + +module type Info = +sig + include State_builder.Info_with_size + type key + val property : key -> property +end + +module type Indexed = +sig + type key + val mem : key -> bool + val property : key -> Property.t + val add_hook : (key -> Property.t -> unit) -> unit +end + +module type Indexed2 = +sig + type key1 + type key2 + val mem : key1 -> key2 -> bool + val property : key1 -> key2 -> Property.t + val add_hook : (key1 -> key2 -> Property.t -> unit) -> unit +end + +(* -------------------------------------------------------------------------- ) +( --- Index-1 Implementation --- ) +( -------------------------------------------------------------------------- ) + +module Indexed + (Key:Datatype.S_with_collections) + (Info:Info with type key = Key.t) = +struct + + open Cil_types + + type key = Key.t + + module H = State_builder.Hashtbl(Key.Hashtbl)(Property)(Info) + + let hooks = ref [] + let add_hook f = hooks := !hooks @ [f] + + let mem = H.mem + + let property (key:key) = + try H.find key + with Not_found -> + let ip = + match Info.property key with + | Later ip -> ip + | Proxy(ip,emitter,ips) -> + Property_status.logical_consequence emitter ip ips ; ip + in + List.iter (fun f -> f key ip) !hooks ; + H.add key ip ; ip + +end + +( -------------------------------------------------------------------------- ) +( --- Index-2 Wrapper --- ) +( -------------------------------------------------------------------------- ) + +module Indexed2 + (Key1:Datatype.S_with_collections) + (Key2:Datatype.S_with_collections) + (Info:Info with type key = Key1.t Key2.t) = +struct + + module P = Datatype.Pair_with_collections(Key1)(Key2) + (struct + let module_name = Info.name + end) + module I = Indexed(P)(Info) + + type key1 = Key1.t + type key2 = Key2.t + + let mem a b = I.mem (a,b) + let property a b = I.property (a,b) + let add_hook f = I.add_hook (fun (a,b) -> f a b) + +end + +(* -------------------------------------------------------------------------- ) + +( +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wprop.mli frama-c-20111001+nitrogen+dfsg/src/wp/wprop.mli --- frama-c-20110201+carbon+dfsg/src/wp/wprop.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wprop.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,76 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +(* ------------------------------------------------------------------------ *) +(**{2 Indexed API} ) +( ------------------------------------------------------------------------ ) + +type property = + | Later of Property.t + | Proxy of Property.t Emitter.t * Property.t list + +module type Info = +sig + include State_builder.Info_with_size + type key + val property : key -> property +end + +module type Indexed = +sig + type key + val mem : key -> bool + val property : key -> Property.t + val add_hook : (key -> Property.t -> unit) -> unit + (** Hooks are executed once at property creation *) +end + +module type Indexed2 = +sig + type key1 + type key2 + val mem : key1 -> key2 -> bool + val property : key1 -> key2 -> Property.t + val add_hook : (key1 -> key2 -> Property.t -> unit) -> unit + (** Hooks are executed once at property creation ) +end + +( ------------------------------------------------------------------------ *) +(**{2 Indexes} ) +( ------------------------------------------------------------------------ ) + +module Indexed + (Key:Datatype.S_with_collections) + (Info:Info with type key = Key.t) : + Indexed with type key = Key.t + +module Indexed2 + (Key1:Datatype.S_with_collections) + (Key2:Datatype.S_with_collections) + (Info:Info with type key = Key1.t Key2.t) : + Indexed2 with type key1 = Key1.t and type key2 = Key2.t + +(* +Local Variables: +compile-command: "make -C ../.." +End: +*) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpStrategy.ml frama-c-20111001+nitrogen+dfsg/src/wp/wpStrategy.ml --- frama-c-20110201+carbon+dfsg/src/wp/wpStrategy.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpStrategy.ml 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,592 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +let dkey = "strategy" (* debugging key ) +let debug fmt = Wp_parameters.debug ~dkey fmt + +open Cil_types + +( -------------------------------------------------------------------------- *) +(** An annotation can be used for different purpose. *) +type annot_kind = + | Ahyp (** annotation is an hypothesis, + but not a goal (see Aboth) : A => ...*) + | Agoal (** annotation is a goal, + but not an hypothesis (see Aboth): A /\ ...*) + | Aboth of bool (** annotation can be used as both hypothesis and goal : + - with true : considerer as both : A /\ A=>.. + - with false : we just want to use it as hyp right now. *) + | AcutB of bool (** annotation is use as a cut : + - with true (A is also a goal) -> A (+ proof obligation A => ...) + - with false (A is an hyp only) -> True (+ proof obligation A => ...) *) + | AcallHyp + (** annotation is a called function property to consider as an Hyp. + * The pre are not here but in AcallPre since they can also + * be considered as goals. *) + | AcallPre of bool + (** annotation is a called function precondition : + to be considered as hyp, and goal if bool=true ) + +( -------------------------------------------------------------------------- ) +( --- Annotations for one program point. --- ) +( -------------------------------------------------------------------------- *) + +(** Some elements can be used as both Hyp and Goal : because of the selection + * mecanism, we need to add a boolean [as_goal] to tell if the element is to be + * considered as a goal. If [false], the element can still be used as hypthesis. + ) +type annots = { + p_hyp : WpPropId.pred_info list; + p_goal : WpPropId.pred_info list; + p_both : (bool WpPropId.pred_info) list; + p_cut : (bool * WpPropId.pred_info) list; + call_hyp : WpPropId.pred_info list; (* post and pre ) + call_pre : (bool WpPropId.pred_info) list; (* goal only ) + a_goal : WpPropId.assigns_full_info; + a_hyp : WpPropId.assigns_full_info; + a_call : WpPropId.assigns_full_info; +} + +type t_annots = { has_asgn_goal : bool; has_prop_goal : bool; info: annots } + +( --- Add annotations --- ) + +let empty_acc = + let a = { p_hyp = []; p_goal = []; p_both = []; p_cut = []; + call_hyp = []; call_pre = []; a_call = WpPropId.empty_assigns_info; + a_goal = WpPropId.empty_assigns_info; a_hyp = WpPropId.empty_assigns_info; } + in { has_asgn_goal = false; has_prop_goal = false; info = a; } + +let add_prop acc kind labels id p = + let get_p () = + let txt = WpPropId.prop_id_name id in + try + let p = NormAtLabels.preproc_annot labels p in + let _ = + debug "take (@[%s:@ %a@])@." txt !Ast_printer.d_predicate_named p + in Some (WpPropId.mk_pred_info id p) + with e -> NormAtLabels.catch_label_error e txt "annotation"; None + in + let add_hyp l = match get_p () with None -> l | Some p -> p::l in + let add_goal l = + ( if goal_to_select config id + then ) match get_p () with None -> l + | Some p -> ( ( has_prop_goal := true; ) p::l ) + ( else l ) + in + let add_both goal l = + match get_p () with None -> l + | Some p -> + ( if goal then has_prop_goal := true;) + (goal, p)::l + in + let info = acc.info in + let goal, info = match kind with + | Ahyp -> + false, { info with p_hyp = add_hyp info.p_hyp } + | Agoal -> + true, { info with p_goal = add_goal info.p_goal } + | Aboth goal -> + goal, { info with p_both = add_both goal info.p_both } + | AcutB goal -> + goal, { info with p_cut = add_both goal info.p_cut } + | AcallHyp -> + false, { info with call_hyp = add_hyp info.call_hyp } + | AcallPre goal -> + goal, { info with call_pre = add_both goal info.call_pre } + in let acc = { acc with info = info } in + if goal then { acc with has_prop_goal = true} else acc + +( -------------------------------------------------------------------------- ) +( adding some specific properties. ) + +let add_prop_fct_pre acc kind kf bhv ~assumes pre = + let id = WpPropId.mk_pre_id kf Kglobal bhv pre in + let labels = NormAtLabels.labels_fct_pre in + let p = Logic_const.pred_of_id_pred pre in + let p = match assumes with None -> p + | Some assumes -> Logic_const.pimplies (assumes, p) + in + let p = Logic_const.pat (p, Logic_const.pre_label) in + ( TODO: why this at ??? [2011-07-08-Anne] *) + add_prop acc kind labels id p + +let add_prop_fct_post acc kind kf bhv tkind post = + let id = WpPropId.mk_fct_post_id kf bhv (tkind, post) in + let labels = NormAtLabels.labels_fct_post in + let p = Logic_const.pred_of_id_pred post in + add_prop acc kind labels id p + +let add_prop_fct_bhv_pre acc kind kf bhv ~impl_assumes = + let assumes = + if impl_assumes then Some (Ast_info.behavior_assumes bhv) else None + in + let add acc p = add_prop_fct_pre acc kind kf bhv ~assumes p in + let acc = List.fold_left add acc bhv.b_requires in + if impl_assumes then acc + else List.fold_left add acc bhv.b_assumes + +let add_prop_stmt_pre acc kind kf s bhv ~assumes pre = + let id = WpPropId.mk_pre_id kf (Kstmt s) bhv pre in + let labels = NormAtLabels.labels_stmt_pre s in + let p = Logic_const.pred_of_id_pred pre in + let p = match assumes with None -> p + | Some assumes -> Logic_const.pimplies (assumes, p) + in add_prop acc kind labels id p + +let add_prop_stmt_bhv_requires acc kind kf s bhv ~with_assumes = + let assumes = + if with_assumes then Some (Ast_info.behavior_assumes bhv) else None + in let add acc pre = + add_prop_stmt_pre acc kind kf s bhv ~assumes pre + in List.fold_left add acc bhv.b_requires + +(** Process the stmt spec precondition as an hypothesis for external properties. + * Add [assumes => requires] for all the behaviors. ) +let add_prop_stmt_spec_pre acc kind kf s spec = + let add_bhv_pre acc bhv = + add_prop_stmt_bhv_requires acc kind kf s bhv ~with_assumes:true + in List.fold_left add_bhv_pre acc spec.spec_behavior + +let add_prop_stmt_post acc kind kf s bhv tkind l_post ~assumes post = + let id = WpPropId.mk_stmt_post_id kf s bhv (tkind, post) in + let labels = NormAtLabels.labels_stmt_post s l_post in + let p = Logic_const.pred_of_id_pred post in + let p = match assumes with None -> p + | Some assumes -> + let assumes = Logic_const.pold assumes in + ( can use old because label normalisation will be called ) + Logic_const.pimplies (assumes, p) + in add_prop acc kind labels id p + +let add_prop_call_pre acc kind id ~assumes pre = + ( TODO: we don't build the id here yet because of strange things in wpAnnot. + * Find out how to deal with it. [2011-07-13-Anne] *) + let labels = NormAtLabels.labels_fct_pre in + let p = Logic_const.pred_of_id_pred pre in + let p = Logic_const.pimplies (assumes, p) in + add_prop acc kind labels id p + +let add_prop_call_post acc kind called_kf bhv tkind ~assumes post = + let id = WpPropId.mk_fct_post_id called_kf bhv (tkind, post) in + let labels = NormAtLabels.labels_fct_post in + let p = Logic_const.pred_of_id_pred post in + let assumes = Logic_const.pold assumes in + let p = Logic_const.pimplies (assumes, p) in + add_prop acc kind labels id p + +let add_prop_assert acc kind kf s ca p = + let id = WpPropId.mk_assert_id kf s ca in + let labels = NormAtLabels.labels_assert_before s in + add_prop acc kind labels id p + +let add_prop_loop_inv acc kind s id p = + let labels = NormAtLabels.labels_loop_inv s in + add_prop acc kind labels id p + +(** apply [f_normal] on the [Normal] postconditions, +* [f_exits] on the [Exits] postconditions, and warn on the others. ) +let fold_bhv_post_cond ~warn f_normal f_exits acc b = + let add (p_acc, e_acc) ((termination_kind, pe) as e) = + match termination_kind with + | Normal -> f_normal p_acc pe, e_acc + | Exits -> p_acc, f_exits e_acc pe + | (Breaks|Continues|Returns) -> ( TODO ) + begin + if warn then + Wp_parameters.warning + "Abrupt statement termination property ignored:@, %a" + (Cil.defaultCilPrinter)#pPost_cond e; + p_acc, e_acc + end + in List.fold_left add acc b.b_post_cond + +( -------------------------------------------------------------------------- ) + +let add_assigns acc kind id a_desc = + let take_assigns () = + debug "take %a %a" WpPropId.pp_id_name id WpPropId.pp_assigns_desc a_desc; + WpPropId.mk_assigns_info id a_desc + in + let info = acc.info in + let goal, info = match kind with + | Ahyp -> false, {info with a_hyp = take_assigns ()} + | AcallHyp -> false, {info with a_call = take_assigns ()} + | Agoal -> true, {info with a_goal = take_assigns ()} + | _ -> Wp_parameters.fatal "Assigns prop can only be Hyp or Goal" + in let acc = { acc with info = info } in + if goal then { acc with has_asgn_goal = true} else acc + +let add_assigns_any acc kind asgn = + let take () = debug "take %a" (WpPropId.pp_assign_info "") asgn; asgn in + match kind with + | Ahyp -> {acc with info = { acc.info with a_hyp = take ()}} + | AcallHyp -> {acc with info = { acc.info with a_call = take ()}} + | _ -> Wp_parameters.fatal "Assigns Any prop can only be Hyp" + +let assigns_upper_bound spec = + let bhvs = spec.spec_behavior in + let upper a b = + match a, b.b_assigns with + | None, Writes a when Cil.is_default_behavior b -> + Some (b,a) ( default behavior always applies. ) + | None, _ -> None ( WritesAny U X -> WritesAny ) + | Some (b,_), _ when Cil.is_default_behavior b -> + a ( default behavior prevails over other behaviors. ) + | Some _, WritesAny -> + None ( No default behavior and one behavior assigns everything. ) + | Some(b,a1), Writes a2 -> Some (b,a1 @ a2) + ( take the whole list of assigns. ) + in + match bhvs with + | [] -> None + | bhv::bhvs -> + ( [VP 2011-02-04] Note that if there is no default and each + behavior has a proper assigns clause we put dependencies only + to the assigns of a more or less randomly selected behavior, + but the datatypes above can't handle anything better. ) + let acc = + match bhv.b_assigns with + WritesAny -> None + | Writes a -> Some(bhv,a) + in + List.fold_left upper acc bhvs + +( [VP 2011-02-04] These two functions below mix all the assigns of + a function regardless of the behavior. At least now that we take + WritesAny as soon as at least one behavior has no assigns clause, + this is correct, but still imprecise. Needs refactoring of t_annots to + go further, though. + [AP 2011-03-11] I think that the merge of all assigns properties + is intended because we are using it as an hypothesis to skip the statement + or the function call. + ) +let add_stmt_spec_assigns_hyp acc kf s l_post spec = + match assigns_upper_bound spec with + | None -> + add_assigns_any acc Ahyp + (WpPropId.mk_stmt_any_assigns_info s) + | Some(bhv, assigns) -> + let id = WpPropId.mk_stmt_assigns_id kf s bhv assigns in + match id with + | None -> add_assigns_any acc Ahyp + (WpPropId.mk_stmt_any_assigns_info s) + | Some id -> + let labels = NormAtLabels.labels_stmt_assigns s l_post in + let assigns = NormAtLabels.preproc_assigns labels assigns in + let a_desc = WpPropId.mk_stmt_assigns_desc s assigns in + add_assigns acc Ahyp id a_desc + +let add_call_assigns_hyp acc kf_caller s l_post spec_opt = + match spec_opt with + | None -> + let asgn = WpPropId.mk_stmt_any_assigns_info s in + add_assigns_any acc AcallHyp asgn + | Some spec -> + match assigns_upper_bound spec with + | None -> + let asgn = WpPropId.mk_stmt_any_assigns_info s in + add_assigns_any acc AcallHyp asgn + | Some(bhv, assigns) -> + let id = WpPropId.mk_stmt_assigns_id kf_caller s bhv assigns in + match id with + | None -> + let asgn = WpPropId.mk_stmt_any_assigns_info s in + add_assigns_any acc AcallHyp asgn + | Some id -> + let labels = NormAtLabels.labels_stmt_assigns s l_post in + let assigns = NormAtLabels.preproc_assigns labels assigns in + let a_desc = WpPropId.mk_stmt_assigns_desc s assigns in + add_assigns acc AcallHyp id a_desc + +( [VP 2011-01-28] following old behavior, not sure it is correct: + why should we give to add_assigns the assigns with unnormalized labels? + [AP 2011-03-11] to answer VP question, the source assigns are only used to + build an identifier for the property which is use later to update its status + and dependencies so we need to have the original one. +) +let add_loop_assigns_hyp acc kf s asgn_opt = match asgn_opt with + | None -> + let asgn = WpPropId.mk_loop_any_assigns_info s in + add_assigns_any acc Ahyp asgn + | Some (ca, assigns) -> + let id = WpPropId.mk_loop_assigns_id kf s ca assigns in + match id with + | None -> + let asgn = WpPropId.mk_loop_any_assigns_info s in + add_assigns_any acc Ahyp asgn + | Some id -> + let labels = NormAtLabels.labels_loop_assigns s in + let assigns' = NormAtLabels.preproc_assigns labels assigns in + let a_desc = WpPropId.mk_loop_assigns_desc s assigns' in + add_assigns acc Ahyp id a_desc + +let add_fct_bhv_assigns_hyp acc kf tkind b = match b.b_assigns with + | WritesAny -> + let id = WpPropId.mk_kf_any_assigns_info () in + add_assigns_any acc Ahyp id + | Writes assigns -> + let id = WpPropId.mk_fct_assigns_id kf b tkind assigns in + match id with + | None -> + let id = WpPropId.mk_kf_any_assigns_info () in + add_assigns_any acc Ahyp id + | Some id -> + let labels = NormAtLabels.labels_fct_assigns in + let assigns' = NormAtLabels.preproc_assigns labels assigns in + let a_desc = WpPropId.mk_kf_assigns_desc assigns' in + add_assigns acc Ahyp id a_desc + +( --- Get annotations --- ) + +let get_goal_only annots = annots.info.p_goal + +let get_hyp_only annots = annots.info.p_hyp + +let filter_both l = + let add (h_acc, g_acc) (goal, p) = + p::h_acc, if goal then p::g_acc else g_acc + in List.fold_left add ([], []) l + +let get_both_hyp_goals annots = filter_both annots.info.p_both + +let get_call_hyp annots = annots.info.call_hyp +let get_call_pre annots = filter_both annots.info.call_pre + +let get_cut annots = annots.info.p_cut + +let get_asgn_hyp annots = annots.info.a_hyp + +let get_asgn_goal annots = annots.info.a_goal + +let get_call_asgn annots = annots.info.a_call + +( --- Print annotations --- ) + +let pp_annots fmt acc = + let acc = acc.info in + let pp_pred k b p = + Format.fprintf fmt "%s%s: %a@." + k (if b then "" else " (h)") WpPropId.pp_pred_of_pred_info p + in + let pp_pred_list k l = List.iter (fun p -> pp_pred k true p) l in + let pp_pred_b_list k l = List.iter (fun (b, p) -> pp_pred k b p) l in + pp_pred_list "H" acc.p_hyp; + pp_pred_list "G" acc.p_goal; + pp_pred_b_list "H+G" acc.p_both; + pp_pred_b_list "C" acc.p_cut; + pp_pred_list "CallHyp" acc.call_hyp; + pp_pred_b_list "CallPre" acc.call_pre; + WpPropId.pp_assign_info "HA" fmt acc.a_hyp; + WpPropId.pp_assign_info "GA" fmt acc.a_goal; + WpPropId.pp_assign_info "CallA" fmt acc.a_call + +( TODO: it should be possible to do without this, but needs a big refactoring) +let merge_acc acc1 acc2 = +{ + p_hyp = acc1.p_hyp @ acc2.p_hyp; + p_goal = acc1.p_goal @ acc2.p_goal; + p_both = acc1.p_both @ acc2.p_both; + p_cut = acc1.p_cut @ acc2.p_cut; + call_hyp = acc1.call_hyp @ acc2.call_hyp; + call_pre = acc1.call_pre @ acc2.call_pre; + a_goal = WpPropId.merge_assign_info acc1.a_goal acc2.a_goal; + a_hyp = WpPropId.merge_assign_info acc1.a_hyp acc2.a_hyp; + a_call = WpPropId.merge_assign_info acc1.a_call acc2.a_call; +} + +( -------------------------------------------------------------------------- ) +( --- Annotation table --- ) +( -------------------------------------------------------------------------- *) + +(** This is an Hashtbl where some predicates are stored on CFG edges. + * On each edge, we store hypotheses and goals. + ) +module Hannots = Cil2cfg.HE (struct type t = annots end) + +type annots_tbl = { + tbl_annots : Hannots.t; + mutable tbl_axioms : WpPropId.axiom_info list; + mutable tbl_has_prop_goal : bool; + mutable tbl_has_asgn_goal : bool; +} + +let create_tbl () = { + tbl_annots = Hannots.create 7; + tbl_axioms = []; + tbl_has_prop_goal = false; + tbl_has_asgn_goal = false; +} + +let add_on_edges tbl new_acc edges = + if new_acc.has_prop_goal then tbl.tbl_has_prop_goal <- true; + if new_acc.has_asgn_goal then tbl.tbl_has_asgn_goal <- true; + let add_on_edge e = + let acc = + try + let acc = Hannots.find tbl.tbl_annots e in + merge_acc new_acc.info acc + with Not_found -> new_acc.info + in Hannots.replace tbl.tbl_annots e acc; + in List.iter add_on_edge edges + +let add_node_annots tbl cfg v (before, (post, exits)) = + add_on_edges tbl before (Cil2cfg.get_pre_edges cfg v); + if post <> empty_acc then + begin + let edges_after = Cil2cfg.get_post_edges cfg v in + if edges_after = [] + then Wp_parameters.warning ~once:true + "Ignoring annotation rooted after statement with no succ" + else add_on_edges tbl post edges_after + end; + if exits <> empty_acc then + begin + let edges_exits = Cil2cfg.get_exit_edges cfg v in + if edges_exits = [] + then ( unreachable (see [process_unreached_annots]) ) () + else add_on_edges tbl exits edges_exits + end + +let add_loop_annots tbl cfg vloop ~entry ~back ~core = + debug "[add_loop_annots]@."; + let edges_to_head = Cil2cfg.succ_e cfg vloop in + debug "[add_loop_annots] %d edges_to_head" (List.length edges_to_head); + let edges_to_loop = Cil2cfg.pred_e cfg vloop in + debug "[add_loop_annots] %d edges_to_loop" (List.length edges_to_loop); + let back_edges, entry_edges = + List.partition Cil2cfg.is_back_edge edges_to_loop + in + debug "[add_loop_annots] %d back_edges + %d entry_edges" + (List.length back_edges) (List.length entry_edges); + add_on_edges tbl entry entry_edges; + debug "[add_loop_annots on entry_edges ok]@."; + add_on_edges tbl back back_edges; + debug "[add_loop_annots on back_edges ok]@."; + add_on_edges tbl core edges_to_head; + debug "[add_loop_annots on edges_to_head ok]@." + +let add_axiom tbl name labels a = + try + let a = NormAtLabels.preproc_annot NormAtLabels.labels_axiom a in + let labels = + List.map (NormAtLabels.preproc_label NormAtLabels.labels_axiom) labels in + let axiom = WpPropId.mk_axiom_info name labels a in + debug "take %a@." WpPropId.pp_axiom_info axiom; + tbl.tbl_axioms <- axiom::tbl.tbl_axioms + with e -> + NormAtLabels.catch_label_error e ("axiom "^name) "axiom" + +let add_all_axioms tbl = + let globs = Globals.Annotations.get_all () in + let globs = List.map (fun (g, _generated) -> g) globs in + let rec do_g g = + match g with + | Daxiomatic (_ax_name, globs,_) -> do_globs globs + | Dlemma (name, _is_axiom, labels, _, pred,_) -> + add_axiom tbl name labels pred + | _ -> () + and do_globs globs = List.iter do_g globs in + do_globs globs + +let get_annots tbl e = + try ( TODOclean : this is not very nice ! ) + let info = Hannots.find tbl.tbl_annots e in { empty_acc with info = info} + with Not_found -> empty_acc + +( -------------------------------------------------------------------------- ) +( --- Strategy --- ) +( -------------------------------------------------------------------------- ) + +type strategy_for_froms = { + get_pre : unit -> t_annots; + more_vars : logic_var list +} + +type strategy_kind = + | SKannots ( normal mode for annotations ) + | SKfroms of strategy_for_froms + +( an object of this type is the only access to annotations + * from the rest of the application. + * The idea is to be able to tune which properties to use for a computation. ) +type strategy = { + desc : string ; + cfg : Cil2cfg.t; + behavior_name : string option ; + + new_loops : bool; + + strategy_kind : strategy_kind; + annots : annots_tbl; +} + +let mk_strategy desc cfg bhv_name new_loops kind tbl = { + desc = desc; cfg = cfg; behavior_name = bhv_name; new_loops = new_loops; + strategy_kind = kind; annots = tbl; +} + +let cfg_of_strategy strat = strat.cfg +let behavior_name_of_strategy strat = strat.behavior_name +let global_axioms strat = strat.annots.tbl_axioms +let strategy_kind strat = strat.strategy_kind +let strategy_has_prop_goal strat = strat.annots.tbl_has_prop_goal +let strategy_has_asgn_goal strat = strat.annots.tbl_has_asgn_goal +let get_annots strat = get_annots strat.annots +let new_loop_computation strat = strat.new_loops + +let pp_info_of_strategy fmt strat = + Format.fprintf fmt "@[%s@]" strat.desc + +( -------------------------------------------------------------------------- ) +( --- Helpers --- ) +( -------------------------------------------------------------------------- ) + +let is_main_init kf = + if Kernel.LibEntry.get () then false + else + let is_main = + try + let main, _ = Globals.entry_point () in + Kernel_function.equal kf main + with Globals.No_such_entry_point _ -> false + in + debug "'%a' is %sthe main entry point@." + Kernel_function.pretty kf (if is_main then "" else "NOT "); + is_main + +let get_called_kf fct = match fct.enode with + | Lval (Var vkf, NoOffset) -> Some (Globals.Functions.get vkf) + | _ -> None + +let mk_variant_properties kf s ca v = + let vpos_id = WpPropId.mk_var_pos_id kf s ca in + let vdecr_id = WpPropId.mk_var_decr_id kf s ca in + let loc = v.term_loc in + let lhead = Clabels.loop_head_label s in + let vhead = Logic_const.tat ~loc (v, lhead) in + let zero = Cil.lzero ~loc () in + let vpos = Logic_const.prel ~loc (Rle, zero, vhead) in + let vdecr = Logic_const.prel ~loc (Rlt, v, vhead) in + (vpos_id, vpos), (vdecr_id, vdecr) + +( -------------------------------------------------------------------------- *) diff -Nru frama-c-20110201+carbon+dfsg/src/wp/wpStrategy.mli frama-c-20111001+nitrogen+dfsg/src/wp/wpStrategy.mli --- frama-c-20110201+carbon+dfsg/src/wp/wpStrategy.mli 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/src/wp/wpStrategy.mli 2011-10-10 08:38:21.000000000 +0000 @@ -0,0 +1,256 @@ +(**************************************************************************) +(* ) +( This file is part of WP plug-in of Frama-C. ) +( ) +( Copyright (C) 2007-2011 ) +( CEA (Commissariat a l'�nergie atomique et aux �nergies ) +( alternatives) ) +( ) +( you can redistribute it and/or modify it under the terms of the GNU ) +( Lesser General Public License as published by the Free Software ) +( Foundation, version 2.1. ) +( ) +( It 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 Lesser General Public License for more details. ) +( ) +( See the GNU Lesser General Public License version 2.1 ) +( for more details (enclosed in the file licenses/LGPLv2.1). ) +( *) +(**************************************************************************) + +open Cil_types + +(* -------------------------------------------------------------------------- *) +(** This file provide all the functions to build a stategy that can then + * be used by the main generic calculus. ) +( -------------------------------------------------------------------------- ) + +( -------------------------------------------------------------------------- *) +(** {2 Annotations} ) +( -------------------------------------------------------------------------- *) + +(** a set of annotations to be added to a program point. *) +type t_annots + +val empty_acc : t_annots + +(** {3 How to use an annotation} *) + +(** An annotation can be used for different purpose. *) +type annot_kind = + | Ahyp (** annotation is an hypothesis, + but not a goal (see Aboth) : A => ...*) + | Agoal (** annotation is a goal, + but not an hypothesis (see Aboth): A /\ ...*) + | Aboth of bool (** annotation can be used as both hypothesis and goal : + - with true : considerer as both : A /\ A=>.. + - with false : we just want to use it as hyp right now. *) + | AcutB of bool (** annotation is use as a cut : + - with true (A is also a goal) -> A (+ proof obligation A => ...) + - with false (A is an hyp only) -> True (+ proof obligation A => ...) *) + | AcallHyp + (** annotation is a called function property to consider as an Hyp. + * The pre are not here but in AcallPre since they can also + * be considered as goals. *) + | AcallPre of bool + (** annotation is a called function precondition : + to be considered as hyp, and goal if bool=true *) + +(** {3 Adding properties (predicates)} *) + +(** generic function to add a predicate property after normalisation. +* All the [add_prop_xxx] functions below use this one. *) +val add_prop : t_annots -> annot_kind -> + NormAtLabels.label_mapping -> WpPropId.prop_id -> + predicate named -> + t_annots + +(** Add the predicate as a function precondition. +* Add [assumes => pre] if [assumes] is given. *) +val add_prop_fct_pre : t_annots -> annot_kind -> + kernel_function -> funbehavior -> + assumes: predicate named option -> identified_predicate -> t_annots + +(** Add the preconditions of the behavior : +* if [impl_assumes], add [b_assumes => b_requires] +* else add both the [b_requires] and the [b_assumes] *) +val add_prop_fct_bhv_pre : t_annots -> annot_kind -> + kernel_function -> funbehavior -> impl_assumes:bool -> t_annots + +val add_prop_fct_post : t_annots -> annot_kind -> + kernel_function -> funbehavior -> termination_kind -> identified_predicate + -> t_annots + +(** Add the predicate as a stmt precondition. +* Add [assumes => pre] if [assumes] is given. *) +val add_prop_stmt_pre : t_annots -> annot_kind -> + kernel_function -> stmt -> funbehavior -> + assumes: predicate named option -> identified_predicate -> t_annots + +(** Add the predicate as a stmt precondition. +* Add [\old (assumes) => post] if [assumes] is given. *) +val add_prop_stmt_post :t_annots -> annot_kind -> + kernel_function -> stmt -> funbehavior -> termination_kind -> + logic_label option -> assumes:predicate named option -> identified_predicate + -> t_annots + +(** Add all the [b_requires]. Add [b_assumes => b_requires] if [with_assumes] *) +val add_prop_stmt_bhv_requires : t_annots -> annot_kind -> + kernel_function -> stmt -> funbehavior -> with_assumes:bool -> t_annots + +(** Process the stmt spec precondition as an hypothesis for external properties. + * Add [assumes => requires] for all the behaviors. *) +val add_prop_stmt_spec_pre : t_annots -> annot_kind -> + kernel_function -> stmt -> funspec -> t_annots + +val add_prop_call_pre : t_annots -> annot_kind -> WpPropId.prop_id -> + assumes:predicate named -> identified_predicate -> t_annots + +(** Add a postcondition of a called function. Beware that [kf] and [bhv] +* are the called one. *) +val add_prop_call_post : t_annots -> annot_kind -> + kernel_function -> funbehavior -> termination_kind -> + assumes:predicate named -> identified_predicate -> t_annots + +val add_prop_assert : t_annots -> annot_kind -> + kernel_function -> stmt -> code_annotation -> predicate named -> t_annots + +val add_prop_loop_inv : t_annots -> annot_kind -> + stmt -> WpPropId.prop_id -> predicate named -> t_annots + +(** {3 Adding assigns properties} *) + +(** generic function to add an assigns property. *) +val add_assigns : t_annots -> annot_kind -> + WpPropId.prop_id -> WpPropId.assigns_desc -> t_annots + +(** generic function to add a WriteAny assigns property. *) +val add_assigns_any : t_annots -> annot_kind -> + WpPropId.assigns_full_info -> t_annots + +(** shortcut to add a stmt spec assigns property as an hypothesis. *) +val add_stmt_spec_assigns_hyp : t_annots -> kernel_function -> stmt -> + logic_label option -> funspec -> t_annots + +(** shortcut to add a call assigns property as an hypothesis. *) +val add_call_assigns_hyp : t_annots -> kernel_function -> stmt -> + logic_label option -> funspec option -> t_annots + +(** shortcut to add a loop assigns property as an hypothesis. ) +val add_loop_assigns_hyp : t_annots -> kernel_function -> stmt -> + (code_annotation identified_term from list) option -> t_annots + +val add_fct_bhv_assigns_hyp : t_annots -> kernel_function -> termination_kind -> + funbehavior -> t_annots + +val assigns_upper_bound : + funspec -> (funbehavior * identified_term from list) option + +(** {3 Getting information from annotations} ) + +val get_hyp_only : t_annots -> WpPropId.pred_info list +val get_goal_only : t_annots -> WpPropId.pred_info list +val get_both_hyp_goals : t_annots -> + WpPropId.pred_info list WpPropId.pred_info list + +(** the [bool] in [get_cut] results says if the property has to be +* considered as a both goal and hyp ([goal=true], or hyp only ([goal=false]) ) +val get_cut : t_annots -> (bool WpPropId.pred_info) list + +(** To be used as hypotheses arround a call, (the pre are in + * [get_call_pre_goal]) *) +val get_call_hyp : t_annots -> WpPropId.pred_info list + +(** Preconditions of a called function to be considered as hyp and goal +* (similar to [get_both_hyp_goals]). ) +val get_call_pre : t_annots -> WpPropId.pred_info list WpPropId.pred_info list + +val get_asgn_hyp : t_annots -> WpPropId.assigns_full_info +val get_asgn_goal : t_annots -> WpPropId.assigns_full_info +val get_call_asgn : t_annots -> WpPropId.assigns_full_info + +(** {3 Printing} ) + +val pp_annots : Format.formatter -> t_annots -> unit + +( -------------------------------------------------------------------------- *) +(** {2 Annotation table} ) +( -------------------------------------------------------------------------- *) + +type annots_tbl + +val create_tbl : unit -> annots_tbl + +val add_on_edges : annots_tbl -> t_annots -> Cil2cfg.edge list -> unit + +(** [add_node_annots cfg annots v (before, (after, exits))] +* add the annotations for the node : +* @param before preconditions +* @param after postconditions +* @param exits \exits properties +) +val add_node_annots : annots_tbl -> Cil2cfg.t -> Cil2cfg.node -> + (t_annots (t_annots * t_annots)) -> unit + +val add_loop_annots : annots_tbl -> Cil2cfg.t -> Cil2cfg.node -> + entry:t_annots -> back:t_annots -> core:t_annots -> unit + +val add_axiom : annots_tbl -> + string -> logic_label list -> predicate named -> + unit + +val add_all_axioms : annots_tbl -> unit + +(* -------------------------------------------------------------------------- *) +(** {2 Strategy} ) +( -------------------------------------------------------------------------- *) + +type strategy + +type strategy_for_froms = { + get_pre : unit -> t_annots; + more_vars : logic_var list +} + +type strategy_kind = + | SKannots (** normal mode for annotations ) + | SKfroms of strategy_for_froms + +val mk_strategy : string -> Cil2cfg.t -> string option -> bool -> + strategy_kind -> annots_tbl -> strategy + +val get_annots : strategy -> Cil2cfg.edge -> t_annots +val new_loop_computation : strategy -> bool +val strategy_has_asgn_goal : strategy -> bool +val strategy_has_prop_goal : strategy -> bool +val strategy_kind : strategy -> strategy_kind +val global_axioms : strategy -> WpPropId.axiom_info list +val behavior_name_of_strategy : strategy -> string option + +val cfg_of_strategy : strategy -> Cil2cfg.t + +val pp_info_of_strategy : Format.formatter -> strategy -> unit + +( -------------------------------------------------------------------------- *) +(** {2 Other useful things} ) +( -------------------------------------------------------------------------- *) + +(** The function is the main entry point AND it is not a lib entry *) +val is_main_init : Cil_types.kernel_function -> bool + +val get_called_kf : Cil_types.exp -> Cil_types.kernel_function option + +(** apply [f_normal] on the [Normal] postconditions, +* [f_exits] on the [Exits] postconditions, and warn on the others. ) +val fold_bhv_post_cond : warn:bool -> + ('n_acc -> Cil_types.identified_predicate -> 'n_acc) -> + ('e_acc -> Cil_types.identified_predicate -> 'e_acc) -> + 'n_acc 'e_acc -> funbehavior -> 'n_acc * 'e_acc + +val mk_variant_properties : + kernel_function -> stmt -> code_annotation -> term -> + (WpPropId.prop_id * predicate named) + * (WpPropId.prop_id * predicate named) +(* -------------------------------------------------------------------------- ) diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/aorai_test.ml frama-c-20111001+nitrogen+dfsg/tests/aorai/aorai_test.ml --- frama-c-20110201+carbon+dfsg/tests/aorai/aorai_test.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/aorai_test.ml 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,43 @@ +( Small script to test that the code generated by aorai can be parsed again + * by frama-c. + ) + +open Kernel + +include Plugin.Register +(struct + let name = "aorai testing module" + let shortname = "aorai-test" + let help = "utility script for aorai regtests" + end) + +let tmpfile = Filename.temp_file "aorai_test" ".i" + +let () = + at_exit (fun () -> + if Debug.get () >= 1 then + result "Keeping temp file %s" tmpfile + else + try Sys.remove tmpfile with Sys_error _ -> ()) + +let extend () = + let myrun = + let run = !Db.Toplevel.run in + fun f -> + let my_project = Project.create "Reparsing" in + run f; + let chan = open_out tmpfile in + let fmt = Format.formatter_of_out_channel chan in + File.pretty_ast ~prj:(Project.from_unique_name "aorai") ~fmt (); + close_out chan; + Project.set_current my_project; + Files.add tmpfile; + Constfold.off (); + File.pretty_ast (); + + in + Db.Toplevel.run := myrun + +let () = Cmdline.run_during_extending_stage extend + + diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/assigns.c frama-c-20111001+nitrogen+dfsg/tests/aorai/assigns.c --- frama-c-20110201+carbon+dfsg/tests/aorai/assigns.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/assigns.c 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,21 @@ +/ run.config + EXECNOW: make -s tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/assigns.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/assigns_det.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs +/ + +int X; + +void f(void) { X++; } + +/@ assigns X; + behavior foo: + assigns X; +/ +int main () { + //@ assigns X; + X++; + //@ assigns X; + f(); + return X; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/call_tree.c frama-c-20111001+nitrogen+dfsg/tests/aorai/call_tree.c --- frama-c-20110201+carbon+dfsg/tests/aorai/call_tree.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/call_tree.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,4 +1,5 @@ / run.config + EXECNOW: make tests/aorai/aorai_test.cmxs DONTRUN: small example related to U3CAT's WP2 / int x; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/deterministic.i frama-c-20111001+nitrogen+dfsg/tests/aorai/deterministic.i --- frama-c-20110201+carbon+dfsg/tests/aorai/deterministic.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/deterministic.i 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,28 @@ +/ run.config + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/deterministic.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs +/ + +int X; +int Y; + +void g(int x) { + Y=x; +} + +int f(int x) { + X=x; + g(X); + X++; + g(X); + return 0; +} + +int real_main (int c) { + if (c) f(4); + return 0; +} + +int main (int c) { + return real_main(c); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/goto.c frama-c-20111001+nitrogen+dfsg/tests/aorai/goto.c --- frama-c-20110201+carbon+dfsg/tests/aorai/goto.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/goto.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/goto.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/goto.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / int status=0; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/hoare_seq.i frama-c-20111001+nitrogen+dfsg/tests/aorai/hoare_seq.i --- frama-c-20110201+carbon+dfsg/tests/aorai/hoare_seq.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/hoare_seq.i 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config +EXECNOW: make -s tests/aorai/aorai_test.cmxs +OPT: -aorai-automata tests/aorai/hoare_seq.ya -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test +/ + +void f(void) { } + +/@ behavior bhv: + assumes c > 0; + ensures \result == 0; +/ +int main(int c) { + if (c <= 0) { f (); } + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/not_prm.i frama-c-20111001+nitrogen+dfsg/tests/aorai/not_prm.i --- frama-c-20110201+carbon+dfsg/tests/aorai/not_prm.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/not_prm.i 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,8 @@ +/ run.config + EXECNOW: make -s tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/not_prm.ya -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test -main f +/ + +int f(int x) { + return x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/other.c frama-c-20111001+nitrogen+dfsg/tests/aorai/other.c --- frama-c-20110201+carbon+dfsg/tests/aorai/other.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/other.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-automata tests/aorai/other.ya -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/other.ya -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / int x=0; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/seq.i frama-c-20111001+nitrogen+dfsg/tests/aorai/seq.i --- frama-c-20110201+carbon+dfsg/tests/aorai/seq.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/seq.i 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + EXECNOW: make -s tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/seq.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs -aorai-acceptance + / + +void f() { } + +void g() { } + +int main(int c) { + if (c) f(); + g(); + if (c) g(); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/seq_loop.i frama-c-20111001+nitrogen+dfsg/tests/aorai/seq_loop.i --- frama-c-20110201+carbon+dfsg/tests/aorai/seq_loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/seq_loop.i 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,21 @@ +/ run.config + EXECNOW: make -s tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/seq_loop.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs -aorai-acceptance +/ + +int f() {} + +int g() {} + +int main(int c) { + if (c<0) { c = 0; } + if (c>5) { c = 5; } + /@ assert 0<=c<=5; / + while (c) { + f(); + g(); + c--; + } + return 0; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/single_call.i frama-c-20111001+nitrogen+dfsg/tests/aorai/single_call.i --- frama-c-20110201+carbon+dfsg/tests/aorai/single_call.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/single_call.i 2011-10-10 08:38:52.000000000 +0000 @@ -0,0 +1,6 @@ +/ run.config + EXECNOW: make -s tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/single_call.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs -aorai-acceptance +/ + +int main () {} diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_acces_params2.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_acces_params2.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_acces_params2.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_acces_params2.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-automata tests/aorai/test_acces_params2.ya -aorai-test 1 + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/test_acces_params2.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_acces_params.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_acces_params.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_acces_params.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_acces_params.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-automata tests/aorai/test_acces_params.ya -aorai-test 1 + EXECNOW: make -s tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/test_acces_params.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs / int status=0; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle1.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle1.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle1.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle1.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_boucle1.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_boucle1.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / int cpt=3; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle2.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle2.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle2.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle2.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_boucle2.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_boucle2.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / int status=0; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle3.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle3.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle3.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle3.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_boucle3.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_boucle3.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_boucle.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_boucle.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / /@ requires \true; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle_rechercheTableau.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle_rechercheTableau.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_boucle_rechercheTableau.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_boucle_rechercheTableau.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ /* run.config - OPT: -aorai-automata tests/aorai/test_boucle_rechercheTableau.ya -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/test_boucle_rechercheTableau.ya -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_factorial2.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_factorial2.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_factorial2.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_factorial2.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-automata tests/aorai/test_factorial.ya -aorai-test 1 + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/test_factorial.ya -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_factorial.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_factorial.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_factorial.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_factorial.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_factorial.ltl -aorai-test 1 + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_factorial.ltl -aorai-test 1 -load-module tests/aorai/aorai_test.cmxs / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion1.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion1.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion1.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion1.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_recursion1.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_recursion1.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion2.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion2.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion2.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion2.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,6 +1,7 @@ / run.config - OPT: -aorai-buchi tests/aorai/test_recursion2.promela -aorai-test 1 -aorai-acceptance - OPT: -aorai-buchi tests/aorai/test_recursion3.promela -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-buchi tests/aorai/test_recursion2.promela -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs + OPT: -aorai-buchi tests/aorai/test_recursion3.promela -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion4.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion4.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion4.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion4.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ /* run.config - OPT: -aorai-automata tests/aorai/test_recursion4.ya -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/test_recursion4.ya -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / # pragma JessieIntegerModel(math) diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion5.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion5.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_recursion5.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_recursion5.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-automata tests/aorai/test_recursion5.ya -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/test_recursion5.ya -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_struct.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_struct.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_struct.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_struct.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-automata tests/aorai/test_struct.ya -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-automata tests/aorai/test_struct.ya -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / struct People{ diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_switch2.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch2.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_switch2.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch2.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_switch2.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_switch2.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / int status=0; diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_switch3.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_switch3.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / / Calcul de la longueur cumulee des chaines de caracteres prises en parametre / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3_et_recursion.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3_et_recursion.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3_et_recursion.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3_et_recursion.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_switch3_et_recursion.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_switch3_et_recursion.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / / Calcul de la longueur cumulee des chaines de caracteres prises en parametre / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3_if.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3_if.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3_if.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3_if.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_switch3.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_switch3.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / / Calcul de la longueur cumulee des chaines de caracteres prises en parametre / diff -Nru frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3_return.c frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3_return.c --- frama-c-20110201+carbon+dfsg/tests/aorai/test_switch3_return.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/aorai/test_switch3_return.c 2011-10-10 08:38:52.000000000 +0000 @@ -1,5 +1,6 @@ / run.config - OPT: -aorai-ltl tests/aorai/test_switch3.ltl -aorai-test 1 -aorai-acceptance + EXECNOW: make tests/aorai/aorai_test.cmxs + OPT: -aorai-ltl tests/aorai/test_switch3.ltl -aorai-test 1 -aorai-acceptance -load-module tests/aorai/aorai_test.cmxs / / Calcul de la longueur cumulee des chaines de caracteres prises en parametre / diff -Nru frama-c-20110201+carbon+dfsg/tests/bugs/switch.i frama-c-20111001+nitrogen+dfsg/tests/bugs/switch.i --- frama-c-20110201+carbon+dfsg/tests/bugs/switch.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/bugs/switch.i 2011-10-10 08:39:08.000000000 +0000 @@ -0,0 +1,8 @@ +int g(int); + +void f(void) { + int x = 0; + switch (1) { + case 1: x = (int)g(x); + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/cil/bts882.i frama-c-20111001+nitrogen+dfsg/tests/cil/bts882.i --- frama-c-20110201+carbon+dfsg/tests/cil/bts882.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/cil/bts882.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,13 @@ +/ run.config + OPT:-print +/ +void main () { + int r; + switch(1) { + case 2: + r = (int) f(1); + break; + default: + break; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/cil/bts892.i frama-c-20111001+nitrogen+dfsg/tests/cil/bts892.i --- frama-c-20110201+carbon+dfsg/tests/cil/bts892.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/cil/bts892.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,15 @@ +int tab[16]; + +void main(void) +{ + int i; + + static const int* t[] = { + &tab[1], + &tab[3], + &tab[4], + &i + }; + + return &t; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/cil/comments.c frama-c-20111001+nitrogen+dfsg/tests/cil/comments.c --- frama-c-20110201+carbon+dfsg/tests/cil/comments.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/cil/comments.c 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,11 @@ +/* run.config + OPT: -print -keep-comments +/ +/ ABC / +void f() {} +//ABD/FOO/ +/ABC/ +/ABC + / +/@ requires \true ; // FOO / +void g() {} diff -Nru frama-c-20110201+carbon+dfsg/tests/cil/empty_cond.c frama-c-20111001+nitrogen+dfsg/tests/cil/empty_cond.c --- frama-c-20110201+carbon+dfsg/tests/cil/empty_cond.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/cil/empty_cond.c 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,5 @@ +int y,z; +void main(int x) { + if(z++) ; + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/cil/ocaml32bits3_11_0.i frama-c-20111001+nitrogen+dfsg/tests/cil/ocaml32bits3_11_0.i --- frama-c-20110201+carbon+dfsg/tests/cil/ocaml32bits3_11_0.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/cil/ocaml32bits3_11_0.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,4 @@ +enum { + OK=0x1111EEEEu, + KO=0x99996666u, // fixed bug of Ocaml 32bits 3.11.0 + } v ; diff -Nru frama-c-20110201+carbon+dfsg/tests/cil/union_to_union.i frama-c-20111001+nitrogen+dfsg/tests/cil/union_to_union.i --- frama-c-20110201+carbon+dfsg/tests/cil/union_to_union.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/cil/union_to_union.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,10 @@ +union X { + int a; + short b; +}; +int main() +{ + union X u,v; + v = (union X) u; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/constant_propagation/const_field_return_struct.i frama-c-20111001+nitrogen+dfsg/tests/constant_propagation/const_field_return_struct.i --- frama-c-20110201+carbon+dfsg/tests/constant_propagation/const_field_return_struct.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/constant_propagation/const_field_return_struct.i 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,13 @@ +/ run.config + OPT: -val -semantic-const-folding -journal-disable +/ + +struct S { + const int f0; + int f1; } T, U; + +struct S main(int c) +{ + if (c) return T; + return U; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/constant_propagation/introduction_of_non_explicit_cast.ml frama-c-20111001+nitrogen+dfsg/tests/constant_propagation/introduction_of_non_explicit_cast.ml --- frama-c-20110201+carbon+dfsg/tests/constant_propagation/introduction_of_non_explicit_cast.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/constant_propagation/introduction_of_non_explicit_cast.ml 2011-10-10 08:39:04.000000000 +0000 @@ -3,7 +3,7 @@ let all = Datatype.String.Set.empty in let new_proj = !Db.Constant_Propagation.get all true in Project.set_current new_proj; - Parameters.CodeOutput.output "After Constant propagation :@."; + Kernel.CodeOutput.output (fun fmt -> Format.fprintf fmt "After Constant propagation :@.") ; File.pretty_ast ~prj:new_proj ();; let () = Db.Main.extend main diff -Nru frama-c-20110201+carbon+dfsg/tests/dynamic/abstract2.ml frama-c-20111001+nitrogen+dfsg/tests/dynamic/abstract2.ml --- frama-c-20110201+carbon+dfsg/tests/dynamic/abstract2.ml 2011-02-07 13:41:25.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/dynamic/abstract2.ml 2011-10-10 08:38:38.000000000 +0000 @@ -3,7 +3,6 @@ type t = string let ty = Type.register ~name:"AA.t" ~ml_name:None Structural_descr.Unknown [ "" ] - let () = Type.is_dynamic_abstract ty let mk = Dynamic.register ~plugin:"AA" ~journalize:false "mk" (Datatype.func Datatype.unit ty) @@ -14,7 +13,6 @@ type t = float let ty = Type.register ~name:"BB.t" ~ml_name:None Structural_descr.Unknown [ 1.0 ] - let () = Type.is_dynamic_abstract ty let print = Dynamic.register ~plugin:"BB" ~journalize:false "print" (Datatype.func ty Datatype.unit) @@ -22,13 +20,14 @@ end let main () = - let a = Type.get "AA.t" in - let b = Type.get "BB.t" in - let s = Dynamic.get ~plugin:"AA" "mk" (Datatype.func Datatype.unit a) () in - try - Dynamic.get ~plugin:"BB" "print" (Datatype.func b Datatype.unit) s; - assert false - with Dynamic.Incompatible_type s -> - print_endline s + let module A = Type.Abstract(struct let name = "AA.t" end) in + let a = A.ty in + let module B = Type.Abstract(struct let name = "BB.t" end) in + let _b = B.ty in + let _s = Dynamic.get ~plugin:"AA" "mk" (Datatype.func Datatype.unit a) () in + ( is now statically checked and no more dynamically ) +( Dynamic.get ~plugin:"BB" "print" (Datatype.func b Datatype.unit) s;) + () + let () = Db.Main.extend main diff -Nru frama-c-20110201+carbon+dfsg/tests/dynamic/abstract.ml frama-c-20111001+nitrogen+dfsg/tests/dynamic/abstract.ml --- frama-c-20110201+carbon+dfsg/tests/dynamic/abstract.ml 2011-02-07 13:41:25.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/dynamic/abstract.ml 2011-10-10 08:38:38.000000000 +0000 @@ -5,12 +5,10 @@ type u = float let mk () = 1.05 let f = function A n -> n | B false -> min_int | B true -> max_int - let t : t Type.t = + let t = Type.register ~name:"A.t" ~ml_name:None Structural_descr.Unknown [ A 1 ] - let () = Type.is_dynamic_abstract t - let u : u Type.t = + let u = Type.register ~ml_name:None ~name:"A.u" Structural_descr.Unknown [ 1.0 ] - let () = Type.is_dynamic_abstract u let mk = Dynamic.register ~plugin:"A" ~journalize:false "mk" (Datatype.func Datatype.unit u) @@ -46,11 +44,12 @@ (Datatype.func (Datatype.func t Datatype.int) (Datatype.func t u)) (fun f x -> float (f x)) - let _ = ignore (Dynamic.get ~plugin:"A" "mk" (Datatype.func Datatype.unit u) ()) + let _ = + ignore (Dynamic.get ~plugin:"A" "mk" (Datatype.func Datatype.unit u) ()) - let _ = - (Dynamic.get ~plugin:"A" "mk" - (Datatype.func Datatype.unit (Type.get "A.u")) ()) + module U = Type.Abstract(struct let name = "A.u" end) + let __ : U.t = + Dynamic.get ~plugin:"A" "mk" (Datatype.func Datatype.unit U.ty) () let _ = Dynamic.register ~journalize:false ~plugin:"A" "poly" @@ -64,10 +63,12 @@ ( use of the abstract functions ) module B = struct - let ty = Type.get "A.t" + module T = Type.Abstract(struct let name = "A.t" end) + let ty = T.ty let _ = Type.register ~ml_name:None ~name:"B.t" Structural_descr.Unknown [ 0.0 ] - let ty' = Type.get "A.u" + module U = Type.Abstract(struct let name = "A.u" end) + let ty' = U.ty let fut = Datatype.func Datatype.unit ty' let mk = Dynamic.get ~plugin:"A" "mk" fut let g = Dynamic.get ~plugin:"A" "g" (Datatype.func ty' Datatype.int) @@ -102,14 +103,14 @@ assert false with Dynamic.Incompatible_type s -> print_endline s - let () = + ( let () = (* is now statically checked and no more dynamically ) try List.iter (Dynamic.get ~plugin:"A" "ppu" (Datatype.func ty' Datatype.unit)) (Dynamic.get ~plugin:"A" "poly" (Datatype.list ty')); assert false with Dynamic.Incompatible_type s -> - print_endline s + print_endline s) let () = List.iter (Dynamic.get ~plugin:"A" "ppu" (Datatype.func ty' Datatype.unit)) diff -Nru frama-c-20110201+carbon+dfsg/tests/dynamic/dynamic.i frama-c-20111001+nitrogen+dfsg/tests/dynamic/dynamic.i --- frama-c-20110201+carbon+dfsg/tests/dynamic/dynamic.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/dynamic/dynamic.i 2011-10-10 08:38:38.000000000 +0000 @@ -0,0 +1,4 @@ +/run.config + COMMENT: cf test_config + OPT: -add-path tests/dynamic/file_path -add-path tests/dynamic/directory_path -add-path tests/dynamic/none -dynamic-test + / diff -Nru frama-c-20110201+carbon+dfsg/tests/dynamic_plugin/apply.ml frama-c-20111001+nitrogen+dfsg/tests/dynamic_plugin/apply.ml --- frama-c-20110201+carbon+dfsg/tests/dynamic_plugin/apply.ml 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/dynamic_plugin/apply.ml 2011-10-10 08:39:08.000000000 +0000 @@ -21,7 +21,7 @@ let main () = - if Parameters.Dynamic.Bool.get "-dynamic-test" then begin + if Dynamic.Parameter.Bool.get "-dynamic-test" () then begin ignore (Dynamic.get ~plugin:"Register_mod2" "g_test" (func int int) 41); try Dynamic.get ~plugin:"Register_mod2" "g_test" diff -Nru frama-c-20110201+carbon+dfsg/tests/float/absorb.c frama-c-20111001+nitrogen+dfsg/tests/float/absorb.c --- frama-c-20110201+carbon+dfsg/tests/float/absorb.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/absorb.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,12 +1,13 @@ /* run.config - EXECNOW: BIN absorb.sav LOG absorb_sav.res LOG absorb_sav.err ./bin/toplevel.opt -memory-footprint 1 -val -journal-disable share/builtin.c -float-hex -save ./tests/float/result/absorb.sav tests/float/absorb.c > tests/float/result/absorb_sav.res 2> tests/float/result/absorb_sav.err - OPT: -load ./tests/float/result/absorb.sav -deps -out -input + EXECNOW: BIN absorb.sav LOG absorb_sav.res LOG absorb_sav.err ./bin/toplevel.opt -memory-footprint 1 -journal-disable share/builtin.c -save ./tests/float/result/absorb.sav tests/float/absorb.c > tests/float/result/absorb_sav.res 2> tests/float/result/absorb_sav.err + EXECNOW: BIN absorb.sav2 LOG absorb_sav2.res LOG absorb_sav2.err ./bin/toplevel.opt -load ./tests/float/result/absorb.sav -val -journal-disable -float-hex -save ./tests/float/result/absorb.sav2 > tests/float/result/absorb_sav2.res 2> tests/float/result/absorb_sav2.err + OPT: -load ./tests/float/result/absorb.sav2 -deps -out -input OPT: -all-rounding-modes -memory-footprint 1 -val -deps -out -input -journal-disable -float-hex share/builtin.c / #include "share/builtin.h" -float x = 1.0, y = 0.0, z, t; +float x = 1.0, y = 0.0, z, t, min_f, min_fl, den; void main() { long long b = Frama_C_interval(-2000000001, 2000000001); @@ -17,4 +18,7 @@ y = x ; x+=1E-286; } t = b; + min_f = 1.175494351e-38; + min_fl = -1.1754943505e-38; + den = min_f / 128.; } diff -Nru frama-c-20110201+carbon+dfsg/tests/float/const.i frama-c-20111001+nitrogen+dfsg/tests/float/const.i --- frama-c-20110201+carbon+dfsg/tests/float/const.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/const.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,123 @@ +/ run.config + OPT: -memory-footprint 1 -val -out -deps -float-hex -journal-disable +/ +typedef double mydouble; + +float f0, f_ , f00, f1 = 3.0, f2, f3, f_0, f13, f26, fic0,fic1,fic2,fic4, fec0,fec2,fec4; + +mydouble m0, m_ , m00, m1 = 3.0, m2, m3, m_0, m13, m26; + +double d0, d1 = 3.0, d2, d3, d4, d5, d6, d7; + +int A,B,C,D,E,F,G,H,I,J,K,L,P,Q,R; + +int Am,Bm,Cm,Dm,Em,Fm,Gm,Hm,Im,Jm,Km,Lm; + +int t1,t2,t3,t4,t5,t6,t7,t8,t9,C0=0,C2=2; +int s1,s2,s3,s4,s5,s6,s7,s8,s9; +int if1,if2,if3,ite1,ite2,ite3; +int ca1,ca2,ca3,ca4; + +void main(int c1, int c2) +{ + f_ = - f0; + f_0 = c1 ? f0 : f_; + f00 = - f_; + f2 = f1; + f13 = c1 ? 1.0 : 3.0; + f26 = f13 + f13; + +/@ assert f26 >= -1.0 ; / + + ca1 = f_0; + ca2 = f13; + ca3 = f0; + ca4 = f00; + + m_ = - m0; + m_0 = c1 ? m0 : m_; + m00 = - m_; + m2 = m1; + m13 = c1 ? 1.0 : 3.0; + m26 = m13 + m13; + + if (f2 == f1) + d2 = d1; + f3 = f1 + f0; + if (f3 == f1) + d6 = d1; + + f13 = c1 ? 1.0 : 3.0; + + A = f0 == f_; + B = f0 == f1; + C = f0 == f0; + D = f_ == f1; + E = f_ == f_; + + F = f_0 == f0; + G = f_0 == f_; + H = (c1 ? f0 : 3.0) == f_; + I = (c1 ? f0 : 3.0) == f0; + J = f13 == f_; + K = f13 == f0; + L = f13 == (c2? 3.0 : 5.0); + + P = f13 != (c2? 3.0 : 5.0); + Q = f0 != f_; + R = f0 != f1; + + Am = m0 == m_; + Bm = m0 == m1; + Cm = m0 == m0; + Dm = m_ == m1; + Em = m_ == m_; + + Fm = m_0 == m0; + Gm = m_0 == m_; + Hm = (c1 ? m0 : 3.0) == m_; + Im = (c1 ? m0 : 3.0) == m0; + Jm = m13 == m_; + Km = m13 == m0; + Lm = m13 == (c2? 3.0 : 5.0); + + t1 = f_0 <= f0; + t2 = f0 <= f_0; + t3 = f0 <= f13; + t4 = f13 <= f26; + t5 = f26 <= f13; + t6 = 1.0 <= f26; + t7 = f26 <= 1.0; + t8 = f1 <= f1; + + s1 = f_0 < f0; + s2 = f0 < f_0; + s3 = f0 < f13; + s4 = f13 < f26; + s5 = f26 < f13; + s6 = 1.0 < f26; + s7 = f26 < 1.0; + s8 = f1 < f1; + + d3 = d1 + 2.0; + d4 = d1 + 2; + + if (1.0) if1 = 1; + if (0.0) if2 = 1; + if (-0.0) if3 = 1; + + if (1.0) ite1 = 1; else ite1 = 2; + if (0.0) ite2 = 1; else ite2 = 2; + if (-0.0) ite3 = 1; else ite3 = 2; + + fic0 = C0; + fic1 = 1; + fic2 = C2; + fic4 = C2 + C2; + fec0 = (float) C0; + fec2 = (float) C2; + fec4 = (float) (C2 + C2); + + d5 = (c2 ? -3.0 : 9.0) / f13; + d7 = (c2 ? -3.0 : 9.0) / (-f13); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/float/cte_overflow.i frama-c-20111001+nitrogen+dfsg/tests/float/cte_overflow.i --- frama-c-20110201+carbon+dfsg/tests/float/cte_overflow.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/cte_overflow.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,9 @@ + +int main() +{ + double t=0.0; + + t = 1e500 1e500 * 1e500 * 1e500 * 1e500; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/float/float_cast_implicite.i frama-c-20111001+nitrogen+dfsg/tests/float/float_cast_implicite.i --- frama-c-20110201+carbon+dfsg/tests/float/float_cast_implicite.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/float_cast_implicite.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,18 @@ +int C0 = 0, C2 = 2, CBP = 2000000000; +float fic0, fic1, fic2, fic4, fec0, fec2, fec4, ficbp, ficbn, fecbp, fecbn; + +void main(void) +{ + fic0 = C0; + fic1 = 1; + fic2 = C2; + fic4 = C2 + C2; + fec0 = (float) C0; + fec2 = (float) C2; + fec4 = (float) (C2 + C2); + + ficbp = CBP; + fecbp = (float) CBP; + ficbn = -CBP; + fecbn = (float) (-CBP); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/float/init_float.i frama-c-20111001+nitrogen+dfsg/tests/float/init_float.i --- frama-c-20110201+carbon+dfsg/tests/float/init_float.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/init_float.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,30 @@ +/* run.config + OPT: -memory-footprint 1 -val -journal-disable -float-normal -lib-entry +/ + +typedef struct S { float y; } S; + +S s; + +double r, cv, un, zp, zm, zs; + +long long l; + + +/@ + requires -1000.0 <= x <= 1000.0; + requires 0.0 <= s.y <= 0.0; +/ +int main(float x) +{ + if (l >= 4700000000000000000ll) l = 4700000000000000000ll; + if (l <= 4500000000000000001ll) l = 4500000000000000001ll; + cv = (double)&l + 1.0; + r = x; + s.y = s.y 1.0; + un = 1.0; + zp = un - un; + zm = - (un - un); + zs = zp + zm; + return 1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/float/precise_cos_sin.i frama-c-20111001+nitrogen+dfsg/tests/float/precise_cos_sin.i --- frama-c-20110201+carbon+dfsg/tests/float/precise_cos_sin.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/precise_cos_sin.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,18 @@ +/* run.config + OPT: -memory-footprint 1 -val -obviously-terminates -journal-disable -float-normal share/builtin.c +/ + +double Frama_C_cos_precise(double); +double Frama_C_sin_precise(double); +float Frama_C_float_interval(float, float); + +main(){ + float f = Frama_C_float_interval(-3.1875, -3.1875+0.25); + while (f <= 3.1875) + { + Frama_C_show_each_s((float)Frama_C_sin_precise(f)); + Frama_C_show_each_c((float)Frama_C_cos_precise(f)); + f += 0.25; + } +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/float/round10d.i frama-c-20111001+nitrogen+dfsg/tests/float/round10d.i --- frama-c-20110201+carbon+dfsg/tests/float/round10d.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/round10d.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,17 @@ +/ run.config + OPT: -memory-footprint 1 -val -float-normal -journal-disable -no-results +/ +int main() +{ + double t=0.0; + int i; + Frama_C_show_each_dixieme(0.1); + //@ loop pragma UNROLL 10; + for(i=0;i<10;i++) + { + t = t + 0.1; + Frama_C_show_each_t(t); + } + //@ assert t>=1.0; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/float/s.i frama-c-20111001+nitrogen+dfsg/tests/float/s.i --- frama-c-20110201+carbon+dfsg/tests/float/s.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/float/s.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,265 @@ +/ run.config + OPT: -all-rounding-modes -memory-footprint 1 -val -deps -out -input -journal-disable -float-hex + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -float-hex +/ + +typedef float T1; +typedef int T2; +typedef int T3; +extern int F1(int G1 ) ; +extern int F2(int G2 ) ; +int const G3 = (int const )42; +extern int F3(int G4 ) ; +T3 G5[64] ; +int const G6 = (int const )42; +int G7 ; +T2 G8 ; +T1 const G9[64] = + {(T1 const )2.000f, (T1 const )1.882f, + (T1 const )1.778f, (T1 const )1.684f, + (T1 const )1.600f, (T1 const )1.523f, + (T1 const )1.455f, (T1 const )1.391f, + (T1 const )1.333f, (T1 const )1.280f, + (T1 const )1.231f, (T1 const )1.185f, + (T1 const )1.143f, (T1 const )1.063f, + (T1 const )1.000f, (T1 const )0.944f, + (T1 const )0.895f, (T1 const )0.850f, + (T1 const )0.810f, (T1 const )0.773f, + (T1 const )0.739f, (T1 const )0.708f, + (T1 const )0.680f, (T1 const )0.654f, + (T1 const )0.630f, (T1 const )0.607f, + (T1 const )0.586f, (T1 const )0.567f, + (T1 const )0.548f, (T1 const )0.500f, + (T1 const )0.471f, (T1 const )0.444f, + (T1 const )0.421f, (T1 const )0.400f, + (T1 const )0.381f, (T1 const )0.364f, + (T1 const )0.348f, (T1 const )0.333f, + (T1 const )0.320f, (T1 const )0.308f, + (T1 const )0.296f, (T1 const )0.286f, + (T1 const )0.276f, (T1 const )0.267f, + (T1 const )0.258f, (T1 const )0.250f, + (T1 const )0.236f, (T1 const )0.222f, + (T1 const )0.211f, (T1 const )0.200f, + (T1 const )0.190f, (T1 const )0.182f, + (T1 const )0.174f, (T1 const )0.167f, + (T1 const )0.160f, (T1 const )0.154f, + (T1 const )0.148f, (T1 const )0.143f, + (T1 const )0.138f, (T1 const )0.133f, + (T1 const )0.129f, (T1 const )0.125f, + (T1 const )0.118f, (T1 const )0.111f}; +T1 const G10[64] = + {(T1 const )0.0510143148127383f, + (T1 const )0.0526807976019492f, + (T1 const )0.0547630669950585f, + (T1 const )0.0564281924367408f, + (T1 const )0.0585087059708387f, + (T1 const )0.0605881929148253f, + (T1 const )0.0630821707769080f, + (T1 const )0.0655745547964065f, + (T1 const )0.0680652820004121f, + (T1 const )0.0713835655737245f, + (T1 const )0.0742844385649674f, + (T1 const )0.0780103647018580f, + (T1 const )0.0817318560546706f, + (T1 const )0.0862740143728233f, + (T1 const )0.0908088461410527f, + (T1 const )0.0961582204249914f, + (T1 const )0.1023163627594810f, + (T1 const )0.1055941606958780f, + (T1 const )0.1088672156067600f, + (T1 const )0.1125435499383810f, + (T1 const )0.1166208530287330f, + (T1 const )0.1210964219228140f, + (T1 const )0.1255617070832910f, + (T1 const )0.1304207531449480f, + (T1 const )0.1356698301501220f, + (T1 const )0.1417064222370730f, + (T1 const )0.1481207659913060f, + (T1 const )0.1549068205428340f, + (T1 const )0.1624539893402380f, + (T1 const )0.1707476333220120f, + (T1 const )0.1797704190221740f, + (T1 const )0.1902769765139430f, + (T1 const )0.2014532178568310f, + (T1 const )0.2079499479102800f, + (T1 const )0.2144044999107600f, + (T1 const )0.2215668881520150f, + (T1 const )0.2290455646566350f, + (T1 const )0.2371977623669650f, + (T1 const )0.2452693886855440f, + (T1 const )0.2543404121628250f, + (T1 const )0.2640116929021380f, + (T1 const )0.2745989285199270f, + (T1 const )0.2860443073244380f, + (T1 const )0.2982805530233570f, + (T1 const )0.3112299993821370f, + (T1 const )0.3254401125978740f, + (T1 const )0.3407438063507600f, + (T1 const )0.3572363398164020f, + (T1 const )0.3749169970825380f, + (T1 const )0.3841864461394160f, + (T1 const )0.3939193988832260f, + (T1 const )0.4037685876851210f, + (T1 const )0.4141279920488020f, + (T1 const )0.4243935880669410f, + (T1 const )0.4350918773347630f, + (T1 const )0.4457881609076350f, + (T1 const )0.4562601664070490f, + (T1 const )0.4665646755216170f, + (T1 const )0.4764261613996570f, + (T1 const )0.4852153448066030f, + (T1 const )0.4927158273036620f, + (T1 const )0.4979548345880140f, + (T1 const )0.4999998245403760f, + (T1 const )0.4973478192101480f}; +T1 const G11[64] = + {(T1 const )1.98956292560627f, + (T1 const )1.98886795364206f, + (T1 const )1.98796783271076f, + (T1 const )1.98722262104002f, + (T1 const )1.98625972652367f, + (T1 const )1.98526198121786f, + (T1 const )1.98401870850080f, + (T1 const )1.98272530730105f, + (T1 const )1.98138181029787f, + (T1 const )1.97951261300748f, + (T1 const )1.97780412452634f, + (T1 const )1.97550756211798f, + (T1 const )1.97309869476763f, + (T1 const )1.97000221093885f, + (T1 const )1.96673843085462f, + (T1 const )1.96266592835235f, + (T1 const )1.95767765236944f, + (T1 const )1.95489078253260f, + (T1 const )1.95201610389272f, + (T1 const )1.94867729238996f, + (T1 const )1.94483758350707f, + (T1 const )1.94045626221254f, + (T1 const )1.93591015375954f, + (T1 const )1.93076327766655f, + (T1 const )1.92496731270757f, + (T1 const )1.91799599539423f, + (T1 const )1.91022611722130f, + (T1 const )1.90159460221914f, + (T1 const )1.89149126922623f, + (T1 const )1.87976698860229f, + (T1 const )1.86625870208647f, + (T1 const )1.84951743850643f, + (T1 const )1.83048234524184f, + (T1 const )1.81882080113072f, + (T1 const )1.80679034940091f, + (T1 const )1.79291099198876f, + (T1 const )1.77781047048834f, + (T1 const )1.76062362373384f, + (T1 const )1.74283872793243f, + (T1 const )1.72191035650916f, + (T1 const )1.69845965986100f, + (T1 const )1.67138471193539f, + (T1 const )1.64038363438451f, + (T1 const )1.60513531735156f, + (T1 const )1.56530322933083f, + (T1 const )1.51836086942351f, + (T1 const )1.46365929605818f, + (T1 const )1.39932668102673f, + (T1 const )1.32325202617558f, + (T1 const )1.28000484125813f, + (T1 const )1.23176301086518f, + (T1 const )1.17963335048658f, + (T1 const )1.12069982565629f, + (T1 const )1.05746929909226f, + (T1 const )0.98545468309658f, + (T1 const )0.90574093951495f, + (T1 const )0.81806269246518f, + (T1 const )0.71908167608869f, + (T1 const )0.60686885217797f, + (T1 const )0.48275988506435f, + (T1 const )0.34014381721778f, + (T1 const )0.18070894655987f, + (T1 const )(- 0.00167551588592f), + (T1 const )(- 0.20572395978728f)}; +T1 const G12[32] = + {(T1 const )0.666666666666667f, + (T1 const )0.592592592592593f, + (T1 const )0.533333333333333f, + (T1 const )0.484848484848485f, + (T1 const )0.444444444444444f, + (T1 const )0.410256410256410f, + (T1 const )0.380952380952381f, + (T1 const )0.355555555555556f, + (T1 const )0.333333333333333f, + (T1 const )0.296296296296296f, + (T1 const )0.266666666666667f, + (T1 const )0.242424242424242f, + (T1 const )0.222222222222222f, + (T1 const )0.205128205128205f, + (T1 const )0.190476190476191f, + (T1 const )0.177777777777778f, + (T1 const )0.166666666666667f, + (T1 const )0.148148148148148f, + (T1 const )0.133333333333333f, + (T1 const )0.121212121212121f, + (T1 const )0.111111111111111f, + (T1 const )0.102564102564103f, + (T1 const )0.095238095238095f, + (T1 const )0.088888888888889f, + (T1 const )0.083333333333333f, + (T1 const )0.074074074074074f, + (T1 const )0.066666666666667f, + (T1 const )0.060606060606061f, + (T1 const )0.055555555555556f, + (T1 const )0.051282051282051f, + (T1 const )0.047619047619048f, + (T1 const )0.044444444444445f}; +static T2 G13 ; +static T1 G14 ; +static T1 G15 ; +static T1 G16 ; +static T1 G17 ; +static T1 G18 ; +static T1 G19 ; +void F4(void) +{ T1 V1 ; + T1 V2 ; + T1 V3 ; + int V4 ; + int V5 ; + int V6 ; + int V7 ; + + {{V1 = (float )0.0; + V4 = F1(G13); + G16 = (float )G9[V4];} + + {V5 = F2(G13); +/ JLCo + G14 = (float )(G10[V5] / (T1 const )((float )G3)); + G14 = (float )(G10[V5] / (T1 const )G3); +/ + G14 = (float )(G10[V5] / G3); +} + + {V6 = F2(G13); + G15 = (float )G11[V6];} + + {V7 = F3(G13); + G17 = (float )G12[V7];} + + {G18 = (float )(1.0 / ((double )G14 + 1.0)); + V2 = G15 G18;} + + {V3 = (float )(((double )G14 - 1.0) * (double )G18); + G19 = (G16 * G14) * G18;} + + + return;} + +} +int main(void) +{ int V8 ; + + {F4(); + V8 = 0; + return (V8);} + +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/idct/ieee_1180_1990.c frama-c-20111001+nitrogen+dfsg/tests/idct/ieee_1180_1990.c --- frama-c-20110201+carbon+dfsg/tests/idct/ieee_1180_1990.c 2011-02-07 13:41:25.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/idct/ieee_1180_1990.c 2011-10-10 08:38:37.000000000 +0000 @@ -1,6 +1,6 @@ /* run.config GCC: - OPT: -float-normal -val -deps -out -input tests/idct/idct.c share/math.c -journal-disable + OPT: -float-normal -val -deps -out -input tests/idct/idct.c share/math.c -journal-disable -remove-redundant-alarms / / IEEE_1180_1990: a testbed for IDCT accuracy * Copyright (C) 2001 Renaud Pacalet diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/alias.i frama-c-20111001+nitrogen+dfsg/tests/impact/alias.i --- frama-c-20110201+carbon+dfsg/tests/impact/alias.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/alias.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,20 @@ +/* run.config + STDOPT: +"-impact-pragma f" +"-lib-entry" +"-main f" +"-remove-redundant-alarms" + / + +int P,c; + +/@ requires \valid(x); / +int f(int x) { + /@ impact pragma stmt; / + int y = x; + y = 4; + int a = x + 2; + y = 2; + if (c) + return x; + else { + y = P; + return y; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/called.i frama-c-20111001+nitrogen+dfsg/tests/impact/called.i --- frama-c-20110201+carbon+dfsg/tests/impact/called.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/called.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,28 @@ +/* run.config + STDOPT: +"-impact-pragma g" +"-lib-entry" +"-main g" + STDOPT: +"-impact-pragma h" +"-lib-entry" +"-main h" + / + +int X; + +int f(int x, int y) { X = x; return y; } + +void g() { + int a, b, c, d; + b = 0; + /@ impact pragma stmt; / + a = 0; + c = f(a,b); + d = X; + c = f(a,d); +} + +void h() { + int a, b, c, d; + /@ impact pragma stmt; / + b = 0; + a = 0; + c = f(a,b); + d = X; + c = f(a,d); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/call.i frama-c-20111001+nitrogen+dfsg/tests/impact/call.i --- frama-c-20110201+carbon+dfsg/tests/impact/call.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/call.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,56 @@ +/ run.config + GCC: + STDOPT: +"-impact-pragma main" + STDOPT: +"-impact-pragma main2" +"-main main2" + STDOPT: +"-impact-pragma main3" +"-main main3" + / + +/@ ghost int G; / + +/@ assigns G \from p; / +void p1 (int p); +void p2 (int); +int X; + +void test (void) { + if (X) p1(1); else p2(0); +} + +/ ************************************************************************* / + +void main (int x) { + /@ impact pragma stmt; / + X = x; + test (); +} + +/ ************************************************************************* / + +void call_test (void) { + test (); +} + +void main2(int x) { + /@ impact pragma stmt; / + X = x; + call_test (); +} + +/ ************************************************************************* / + +/@ assigns G; / +void p3 (int); + +void test3 (void) { + if (X) p3(1); else p2(0); +} + +void call_test3 (void) { + test3 (); +} + +void main3(int x) { + /@ impact pragma stmt; / + X = x; + call_test3 (); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/depend1.i frama-c-20111001+nitrogen+dfsg/tests/impact/depend1.i --- frama-c-20110201+carbon+dfsg/tests/impact/depend1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/depend1.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,16 @@ +/ run.config + STDOPT: +"-impact-pragma main" + / + + +int find(int x) { return x; } + +int main() +{ + int a = find(1); + /@ impact pragma stmt; / + int b = find(2); + int c = find(b); + int d = find(3); + return c ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/depend2.i frama-c-20111001+nitrogen+dfsg/tests/impact/depend2.i --- frama-c-20110201+carbon+dfsg/tests/impact/depend2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/depend2.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + STDOPT: +"-impact-pragma main" + / + +int find(int x) { return x; } + +int apply(int x,int y) { return find(x)+y; } + +int main() +{ + int a = apply(1,100); + /@ impact pragma stmt; / + int b = apply(2,200); + return a+b ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/first.i frama-c-20111001+nitrogen+dfsg/tests/impact/first.i --- frama-c-20110201+carbon+dfsg/tests/impact/first.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/first.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,19 @@ +/ run.config + GCC: + STDOPT: +"-impact-pragma impact" +"-lib-entry" +"-main impact" + / + +int a, b, c, e, x, y, z, f, w; + +void impact() { + /@ impact pragma stmt; / + b = a; + if (c) { + x = b + c; + y = x + e; + } else + z = 12; + z = 13; + z = y + f; + w = b; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/loop.i frama-c-20111001+nitrogen+dfsg/tests/impact/loop.i --- frama-c-20110201+carbon+dfsg/tests/impact/loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/loop.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,17 @@ +/ run.config + GCC: + STDOPT: +"-impact-pragma loop" +"-lib-entry" +"-main loop" + / + +int c,x,y,z,w; + +void loop () { + while (c) { + z = w + 1; + z = y + 1; + /@ impact pragma stmt; / + x = x + 1; + y = x + 1; + } + w = z; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/slicing.i frama-c-20111001+nitrogen+dfsg/tests/impact/slicing.i --- frama-c-20110201+carbon+dfsg/tests/impact/slicing.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/slicing.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,20 @@ +/ run.config + GCC: + STDOPT: +"-impact-pragma impact" +"-lib-entry" +"-main impact" +"-impact-slicing" +"-then-on 'impact slicing'" +"-print" + / + +int a, b, c, e, x, y, z, f, w; + +void impact() { + if (c) a = 18; else x = 5; + /@ impact pragma stmt; / + b = a; + if (c) { + x = b + c; + y = x + e; + } else + z = 12; + z = 13; + z = y + f; + w = b; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/undef_function.i frama-c-20111001+nitrogen+dfsg/tests/impact/undef_function.i --- frama-c-20110201+carbon+dfsg/tests/impact/undef_function.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/undef_function.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,12 @@ +/ run.config + GCC: + STDOPT: +"-impact-pragma main" + / +int y; + +int main() { + /@ impact pragma stmt; / + y=2; + g(y); + return y; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/impact/variadic.i frama-c-20111001+nitrogen+dfsg/tests/impact/variadic.i --- frama-c-20110201+carbon+dfsg/tests/impact/variadic.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/impact/variadic.i 2011-10-10 08:39:10.000000000 +0000 @@ -0,0 +1,12 @@ +/ run.config + STDOPT: +"-impact-pragma main" + / + +int f(int, ...); + +int main () { + int i=0; + /@ impact pragma stmt; / + i++; + f(i); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/journal/control.i frama-c-20111001+nitrogen+dfsg/tests/journal/control.i --- frama-c-20110201+carbon+dfsg/tests/journal/control.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/journal/control.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,19 @@ +/ run.config + EXECNOW: BIN control_journal.ml BIN control_journal_bis.ml (./bin/toplevel.opt -journal-enable -memory-footprint 1 -val -deps -out -main f -journal-name tests/journal/result/control_journal tests/journal/control.i && cp tests/journal/result/control_journal.ml tests/journal/result/control_journal_bis.ml) > /dev/null 2> /dev/null + CMD: FRAMAC_LIB=lib/fc ./bin/toplevel.byte + OPT: -load-script tests/journal/result/control_journal -journal-disable + CMD: FRAMAC_LIB=lib/fc ./bin/toplevel.byte + OPT: -load-script tests/journal/result/control_journal_bis -calldeps -journal-disable +/ + +int x,y,c,d; + + +void f() { + int i; + for(i=0; i<4 ; i++) { + if (c) { if (d) {y++;} else {x++;}} + else {}; + x=x+1; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/journal/intra.i frama-c-20111001+nitrogen+dfsg/tests/journal/intra.i --- frama-c-20110201+carbon+dfsg/tests/journal/intra.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/journal/intra.i 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,117 @@ +/ run.config + EXECNOW: make -s tests/journal/intra.opt tests/journal/intra.byte + EXECNOW: BIN intra_journal.ml ./tests/journal/intra.opt -journal-enable -journal-name tests/journal/result/intra_journal tests/journal/intra.i > /dev/null 2> /dev/null + CMD: FRAMAC_LIB=lib/fc ./tests/journal/intra.byte + OPT: -load-script tests/journal/result/intra_journal -journal-disable +/ + +/ Waiting for results such as: + * spare code analysis removes statements having variables with + * prefix "spare_" + * + * slicing analysis removes statement having variables with + * prefix "spare_" and "any_" + / + +int G; + +int tmp (int a) { + int x = a; + //@ assert x == a ; + int w = 1; + //@ assert w == 1 ; // w is not spare or else + // the assertion should be removed ! + int spare_z = 1; + int spare_y = a+spare_z; + return x; +} + +int param (int a, int spare_b) { + return a; +} + +int spare_called_fct (int a) { + return a; +} + +int two_outputs (int a, int b) { + G += b; + return a; +} + +int call_two_outputs (void) { + int x, spare_y; + int any_b = 1; + int any_a = 2; + int a = 1; + int b = any_b; + x = two_outputs (a, b); + G = 1; / don't use b = any_b; / + b = 2; + a = any_a; + spare_y = two_outputs (a, b); + / don't use spare_y so don't use a = any_a / + return x; +} + +void assign (int p, int q) { + p = q ; +} + +int loop (int x, int y, int z) { + int i = 0; + //@ assert i < z ; + //@ loop invariant i < y ; + / should keep y in sparecode analysis even if it is not used in the function / + while (i < x) { + i ++; + } + return i; +} + +void stop(void) attribute ((noreturn)) ; + +int main (int noreturn, int halt) { + int res = 0; + int spare_tmp = 3; + int spare_param = 2 + spare_tmp; + int spare_ref = 3; + int x = 1; + int y = 2; + res += param (2, spare_param); + res += tmp (4); + spare_called_fct (5); + res += call_two_outputs (); + res += loop (10, 15, 20); + assign (&x, &spare_ref) ; / <- Here, best can be done for spare analysis / + assign (&x, &y) ; + if (noreturn) { + if (halt) + stop () ; + else + while (1); + //@ assert \false ; // What should be done with + // assertions related to dead code? + } + + return res + G + x; +} + +/-------------------------------------/ +struct { struct { int x; int y; } a; int b; } X10; +int Y10; +int f10 (int x) { + //@ slice pragma expr X10; + //@ slice pragma expr X10.a; + //@ slice pragma expr X10.a.x; + //@ slice pragma expr Y10; + //@ assert X10.a.x >= 0; + return x; +} +int main2 () { + Y10 = 0; + X10.b = 0; + X10.a.y += f10 (3); + return X10.a.x + X10.a.y; +} +/-------------------------------------/ diff -Nru frama-c-20110201+carbon+dfsg/tests/metrics/func_ptr.c frama-c-20111001+nitrogen+dfsg/tests/metrics/func_ptr.c --- frama-c-20110201+carbon+dfsg/tests/metrics/func_ptr.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/metrics/func_ptr.c 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,32 @@ +/ run.config + OPT: -metrics -metrics-value-cover -metrics-cover main + OPT: -metrics -metrics-value-cover -main foobar -metrics-cover foobar +**/ + +void (bar) (int); + +void baz (int j) { return; } + +int foobar () { + bar = baz; + bar (2); + return 0; +} + +void foo (int k) { + int i = 0; + return; +} + +/ foo is unreachable since j is always 0 / +int main() { + int j = 0; + if (!j) { + return 1; + } + else { + bar = foo; + bar (1); + return 0; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/metrics/reach.c frama-c-20111001+nitrogen+dfsg/tests/metrics/reach.c --- frama-c-20110201+carbon+dfsg/tests/metrics/reach.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/metrics/reach.c 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,28 @@ +/ run.config + OPT: -metrics -metrics-by-function -metrics-value-cover +**/ + +void (bar) (int); + +void baz (int j) { return; } + +void (t[2])(int)= {baz, 0}; + +void foo (int k) { + int i = 0; + return; +} + +/* foo is unreachable since j is always 0; baz is not called / +int main() { + int j = 0; + void ((pt)[2])(int) = &t; + if (!j) { + return 1; + } + else { + bar = foo; + bar (1); + return 0; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/metrics/unreachable.c frama-c-20111001+nitrogen+dfsg/tests/metrics/unreachable.c --- frama-c-20110201+carbon+dfsg/tests/metrics/unreachable.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/metrics/unreachable.c 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,19 @@ +/ run.config + OPT: -metrics -metrics-value-cover -then -main foo +**/ +void foo () { + int i = 0; + return; +} + +/* foo is unreachable since j is always 0 / +int main() { + int j = 0; + if (!j) { + return 1; + } + else { + foo (); + return 0; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/abs_addr.i frama-c-20111001+nitrogen+dfsg/tests/misc/abs_addr.i --- frama-c-20110201+carbon+dfsg/tests/misc/abs_addr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/abs_addr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,47 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0x20000-0x3FFFF -journal-disable +/ + +unsigned short AutoTest[1000]={0}; + +unsigned char TstRomUcmm(void) +{ + union {unsigned char byte[2];unsigned short word;} rom; + unsigned short chkrom; + unsigned short ptrom; + + + ptrom = (unsigned short )0x020000; + chkrom = 0; + + while(ptrom != (unsigned short ) 0x02FFFE) + { + rom.word = ptrom; + chkrom = chkrom + rom.byte[0] + rom.byte[1]; + ptrom++; + } + if(chkrom != ptrom) + { + AutoTest[73] = (unsigned short)1; + } + + + ptrom = (unsigned short )0x030000; + chkrom = 0; + while(ptrom != (unsigned short ) 0x03FFFE) + { + rom.word = ptrom; + chkrom = chkrom + rom.byte[0] + rom.byte[1]; + ptrom++; + } + if(chkrom != ptrom) + { + AutoTest[73] = (unsigned short)1; + } + return(AutoTest[73]); +} + +void main(void){ + TstRomUcmm(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/abs.i frama-c-20111001+nitrogen+dfsg/tests/misc/abs.i --- frama-c-20110201+carbon+dfsg/tests/misc/abs.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/abs.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +/* run.config + STDOPT: +"-remove-redundant-alarms" + / + + +//@ requires \valid(p); +void main (int p) { + + if (p<0) p=-p; + + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/absolute_pointer.i frama-c-20111001+nitrogen+dfsg/tests/misc/absolute_pointer.i --- frama-c-20110201+carbon+dfsg/tests/misc/absolute_pointer.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/absolute_pointer.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0-0x3 -journal-disable +/ + +char R; +void main() { + ((char)0)=2; + R = ((char)1); + ((char)2)=2; + R = ((char)3); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/access_path.i frama-c-20111001+nitrogen+dfsg/tests/misc/access_path.i --- frama-c-20110201+carbon+dfsg/tests/misc/access_path.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/access_path.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,3 @@ +int main(int p) { + (p)++; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/add_approx.i frama-c-20111001+nitrogen+dfsg/tests/misc/add_approx.i --- frama-c-20110201+carbon+dfsg/tests/misc/add_approx.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/add_approx.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +int t[10]={0}; +int x; + +void main(int c) +{ + t[1]=1; + if (c) x = 0; else x = 1; + t[x]=2; + + t[3] = 77; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/addition.i frama-c-20111001+nitrogen+dfsg/tests/misc/addition.i --- frama-c-20110201+carbon+dfsg/tests/misc/addition.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/addition.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,97 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0x2D-0x30 -journal-disable +/ + + +int t[10],x,y,z,zz; +int p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16; +unsigned int u1,u3; +int q1; + +int quo1,rem1,quo2,rem2,quo3,rem3,quo4,rem4,quo5,rem5,mm1,mm2,mm3,quo6,c1,c2,qu1,qu2; +long long ll1,ll2; +struct {int a; int b:2; } tt[5]; +int ttt[5][6]; + +int square; + +int main(int u2, int u3) +{ + z = 37; + + quo1 = z/12; + rem1 = z%12; + quo2 = (-z)/12; + rem2 = (-z)%12; + quo3 = (-z)/(-12); + rem3 = (-z)%(-12); + quo4 = (z)/(-12); + rem4 = (z)%(-12); + quo5 = (z-1)/(-12); + rem5 = (z-1)%(-12); + + p1 = (int)(&p2 - &p3); + + p2 = ~((int)&p1); + + p3 = &(t[(char)(&p1)]); + + p4 = &(tt[(char)(&p1)].a); + + p5 = &(ttt[(char)(&p1)][(char)&p2]); + + p6 = &(ttt[(char)(&p1)][u2]); + + p7 = &(ttt[u2][(char)(&p2)]); + + p8 = (&p1 + 1) < &p2; + + p9 = (int)&p1 / 2 ; + + p10 = 12 & ((int)&p1); + + if (u2 < 0) p11 = u2 & (-4); + + p12 = (int)&p1 & (int)(&p2); + + q1 = &p1; + p13 = ((char)&q1)+2; + + p14 = ((char)&q1)+2; + + tt[0].b = 3; + p15 = tt[0].b; + + t[1] = ((int)(45)); + p16=2+((int)((char)t+2)); + + { + int s,t ; + if ((u3 <= 15) && (u3 >= -10)) + s = u3; + else s = 0; + if ((u2 <= 100) && (u2 >= -150)) + t = u2; + else t = 0; + mm1 = (16+32t) * (2+3s); + mm2 = (4+32t) * (16+96s); + mm3 = (1+15t) * (1+35s); + quo6 = (2007+15s) / (-5); + qu1 = (2007+15s) / (20 + s); + qu2 = (7+15s) / (20 + s); + ll1 = (long long)(5s+3) + 0xFFFFFFFFL; + ll2 = (long long)(5s+1) + 0x100000003L; + c1 = (int)ll1; + c2 = (int)ll2; + CEA_1(s); + //@ assert (s >= 0) || (s < 0) ; + square = s * s; + } + + u2 = 34; + u1 = u2 >> 2 ; + + 2[t]=3; + return ((2+t)) + t[2]; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/addr2.i frama-c-20111001+nitrogen+dfsg/tests/misc/addr2.i --- frama-c-20110201+carbon+dfsg/tests/misc/addr2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/addr2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,29 @@ + +int x ; +int t[13] ; +extern void CEA_F(int ) ; +void main(void) +{ int i ; + + { + i = 0; // (&x+i)-&x; + { + { + { + while (1) { + if (i <= 12) { + + } else { + goto L; + } + CEA_F(i); + i += 1; + } + } + } + L: ; + } + + return; +} +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/addr.i frama-c-20111001+nitrogen+dfsg/tests/misc/addr.i --- frama-c-20110201+carbon+dfsg/tests/misc/addr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/addr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable +/ + + +int t[5]; +int x; +int p,q; + +void f(int i) { +// x = t[i]; + p = t+i; +// q = &t[i]; +} + +void main () { + t[2] = 77; + f(2); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/addrofstring.c frama-c-20111001+nitrogen+dfsg/tests/misc/addrofstring.c --- frama-c-20110201+carbon+dfsg/tests/misc/addrofstring.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/addrofstring.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +/ run.config + +/ + +int main() { + + // String literals are lvalues + char (p)[4] = &("bar"); + //wchar_t (q)[4] = &(L"foO"); // Does not work yet + + if((p)[1] != 'a') return -1; + //if((q)[1] != 'o') {}; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/affect_corrupt.i frama-c-20111001+nitrogen+dfsg/tests/misc/affect_corrupt.i --- frama-c-20110201+carbon+dfsg/tests/misc/affect_corrupt.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/affect_corrupt.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0-0x3 -journal-disable +/ +int p,r=77; +void main () { + r = p; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/ai_annot.i frama-c-20111001+nitrogen+dfsg/tests/misc/ai_annot.i --- frama-c-20110201+carbon+dfsg/tests/misc/ai_annot.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/ai_annot.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + STDOPT: +"-remove-redundant-alarms" + / + + +int u,v,w; + +int main(int x,int p) { + /@ assert x >=0; / + /@ assert \valid(p); / + /@ assert \valid(p+1); / + p=x; + + return x+(p+1); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/alias.i frama-c-20111001+nitrogen+dfsg/tests/misc/alias.i --- frama-c-20110201+carbon+dfsg/tests/misc/alias.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/alias.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,302 @@ +/* run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -no-results-function f + OPT: -memory-footprint 1 -val -deps -out -input -main main3 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main4 -absolute-valid-range 0-0xFF -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main5 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main6 -absolute-valid-range 0-0xFF -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main11 -absolute-valid-range 0-0xFF -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main8 -absolute-valid-range 0-0xFF -journal-disable + +/ +void f(charx,inty) { + (x)++; + x++; + (x)++; + (y)++; +} + +void f2(charx) { + char q; + (x)++; + q = x+1; + (q)++; + Frama_C_dump_each(); +} + +int A,B,C,D,E,F,G; +int p[5] = {0,0}; +int q[5] = {1,2,3,4,5}; + +int p2[5] = {0,0}; +int q2[5] = {1,2,3,4,5}; + +int p3[5]; + +int t,u,v,w,x,y,z,t2,v2,PTR1,PTR2,PTR3,PTR4,PTR5, PTR6; + +volatile int c,c1,c2,c3,c4; + +void main (void) { + volatile vol=0; + + / SECTION 1 / + A=1; + B=2; + f(&A,&B); + f(&A,&A); + f(&p,&B); + + / SECTION 2 / + x = 1; + y = 2; + z = 3; + PTR1 = c1? &y : &x; + PTR2 = c2? &y : &z; + PTR3 = PTR1; + + PTR1 = 4; + t = PTR1; + PTR2 = 5; + v = PTR1; + u = PTR2; + w = PTR3; +/ x in {1,4} + && y in {2,4,5} + && t = 4 + && v in {4,5} + && u = 5 + && z in {3,5} +/ + +/ SECTION 3 / + PTR4 = c3? &(p2[1]) : &(q2[2]); + PTR4 = 6; + t2 = PTR4; + PTR4 [-1] = 7; + v2 = (PTR4+(v2-v2-1)); +/* t2 = 6 + && v2 = 7 +/ + + p3[1] = vol; + Frama_C_show_each_d0(p3[1]-vol); + p3[0] = 0; + Frama_C_show_each_d2(p3[1]-vol); +} + +struct S { int a; int b; int c; } e,g; + +void main3() +{ + struct S p,q,s1={2,4,6},s2={1,3,5}; + p = c?&s1:&s2; + p-> a = 7; + t = p->b; + + z = 2; + u = (c+1)?0:1; + v = u; + if (w==v) + { + z = u; + } + + + PTR1 = & ( p2 [(c+1)?0:((c+2)?1:2)] ); + PTR2 = PTR1+1; + PTR1 = (c+10) ? 96 : (c+11) ? 97 : 98; + PTR3 = p2 + ((c+3)?1:((c+4)?2:4)); + PTR3 = 99; + PTR4 = PTR3; + x = PTR1; + if (PTR4==PTR2) + { + t2 = PTR1; + v2 = PTR3 - PTR1; + } + else{ + L: goto L; + } +} + +struct T { struct S s1; struct S s2; struct S s3; struct S s4;} h,i; +void main4() +{ + struct S p,s,ss,sss; + struct T pt, + t1= {1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12}, + t2 ={21,22,23,24,25,26,27,28,29,30,31,32}; + p = c?&(t1.s2):&(t2.s3); + pt = c?(struct T)(&(t1.s2)):(struct T)(&(t2.s3)); + + p->a = 777; + s = p; + + pt -> s1.b = 888; + sss = pt-> s1; + pt = (struct S)0; + ss = pt->s1; + + + z = 1000; + u = (c+1)?0:((c+2)?1:2); + v = u+1; + x = (c+3)?1:((c+4)?2:5); + y = x; + if (y==v) + { + z = u - x; + } +} + +void main5() +{ + struct S p,s,ss,sss; + struct T pt, + t1= {1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12}, + t2 ={21,22,23,24,25,26,27,28,29,30,31,32}; + if(c) { + pt = (struct T)(&(t1.s2)); + pt -> s1.b = 888; + } + else { + pt = (struct T)(&(t2.s3)); + pt -> s1.b = 999; + } + + sss = pt-> s1; + + + z = 2; + u = (c+1)?0:1; + v = u; + if (v==w) + { + z = u; + } +} + + +void main6(void) +{ + int i = 0; + if (c) PTR1 = &p[1]; else PTR1 = &q[2]; + PTR1 = 77; + for (; i<100; i++) + { + x = i; + } + y = PTR1; + PTR2 = (int) PTR2; + if (PTR2 == (char)PTR1) + z = PTR2; + else + z = -33; + + u = c?0:1; + v = u; + w = v; + u = (c+1)?0:1; +} + + +int tz1,tz2,tz3,tx,ty,tz; +void main8(void) +{ + + tx = c?2:3; + ty = tx+1; + tz = ty+2; + + tz1 = tz==ty+2; + tz2 = tz==tx+3; + tz3 = tx==ty-1; + + A = c1 ? 3 : 4; + B = A + 1; + y = B == (A+1); + t = (B + 3) - (A - 1); + PTR1 = c2 ? &p[2] : &q[3]; + PTR2 = (int)((unsigned int)PTR1 + 4); + PTR3 = PTR2 - 1; + u = PTR2; + PTR1[1] = 44; + v = PTR2; + w = PTR1; + PTR1 = 33; + x = PTR1; + z = PTR3; + + if (c3) + { + PTR4 = &q2[1]; + PTR4 = 33; + PTR5 = PTR1; + } + else + { + PTR4 = &q2[2]; + PTR4 = 44; + PTR5 = PTR1 + 1; + } + C = PTR4; + D = PTR5; +} + + + +union u { long long ll ; int i ; char c ; }; + +union u U; +char char1; +long long ll1; + +void main11(void) +{ + int i = 0; + + PTR3 = &p2[1]; + PTR3 = 33; + while (c) + { + int tm = &p2[2]; + tm = tm; + PTR3 = tm-1; + } + D = PTR3; + + f2(p2); + + t = c2?0:1; + ll1 = (c2+1)?15:16; + U.ll = ll1 + 1; + if (c2+2) + U.i = t + 2; + else { L: goto L; } + + if (c) PTR1 = &p[1]; else PTR1 = &q[2]; + PTR1 = 77; + for (; i<100; i++) + { + x = i; + } + y = PTR1; + PTR2 = (int) PTR2; + if (PTR2 == (char)PTR1) + z = PTR2; + else + z = -33; + + PTR4 = &q2[1]; + PTR4 = 33; + while (c1++) + { + PTR4 = &q2[1]; + (PTR4-1) = 33; + } + A = (PTR4 - 1); + B = A - q2[0]; +} + + + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/align_char_array.c frama-c-20111001+nitrogen+dfsg/tests/misc/align_char_array.c --- frama-c-20110201+carbon+dfsg/tests/misc/align_char_array.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/align_char_array.c 2011-10-10 08:39:03.000000000 +0000 @@ -1,8 +1,9 @@ /* run.config OPT: -memory-footprint 1 -val -cpp-command "gcc -C -E -DPTEST" -journal-disable - OPT: -memory-footprint 1 -machdep ppc_32_diab -val -cpp-command "gcc -C -E -DPTEST" -journal-disable / +// removed : OPT: -memory-footprint 1 -machdep ppc_32_diab -val -cpp-command "gcc -C -E -DPTEST" -journal-disable + #ifndef PTEST #include <stdio.h> #endif diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/align.i frama-c-20111001+nitrogen+dfsg/tests/misc/align.i --- frama-c-20110201+carbon+dfsg/tests/misc/align.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/align.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,18 @@ +int c[5][10]; +void main() { + char d; + d = (char)c; + d[2] = 'z'; + ((char)c[2])[1] = (char)'y'; + ((char)c)[1] = (char)'y'; +// ((long long)c[2])[2] = (char)'y'; +// ((char**)c)[1][0] = (char)'y'; // seg fault ! + + c[0] = (int)'x'; + + int l; + int pl = &l; + pl = 0; + ((char)pl)= 2; +// l = l & 0b11111111000000000; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/annot.i frama-c-20111001+nitrogen+dfsg/tests/misc/annot.i --- frama-c-20110201+carbon+dfsg/tests/misc/annot.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/annot.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,42 @@ + +int A, B, C; +int u, v, w; + +/@ requires u == argf && v == 0; + assigns u, v, w \from u; + ensures u != \result; +/ +int main(int argf, int en1, int en2, int en3, int en4) { + int x,y,z,t; + + x = 1; + /@ assert x == 1+u; / + Frama_C_show_each_diff(x - u); + /@ requires y != 2; + @ ensures y == 2; + / + y = 2; + /@ assert y == 2; / + z = 3; + + A = en1 ? 0 : 1; + B = en2 ? 0 : 2; + if (en3) + { + //@ assert A == 0 <==> A != 0 ; + Frama_C_show_each_then_A_B(A,B); + } + else if (en4) + { + //@ assert ! (A == 0 <==> B == A) ; + Frama_C_show_each_elseif_A_B(A,B); + } + else + { + //@ assert A == 0 <==> B == A ; + Frama_C_show_each_else_A_B(A,B); + } + + /@ assert y == z; / + return z; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/annot_valid.i frama-c-20111001+nitrogen+dfsg/tests/misc/annot_valid.i --- frama-c-20110201+carbon+dfsg/tests/misc/annot_valid.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/annot_valid.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,55 @@ +int G; +int main (int u) { + int p = &G; + char c = &G; + + switch (u) { + case 0: + //@ assert \valid(p); + break; + case 1: + //@ assert \valid(p+1); + break; + case 2: + //@ assert \valid((char)p+1); + break; + case 3: + //@ assert \valid(c+1); + break; + case 4: + //@ assert \valid(c+3); + break; + case 5: + //@ assert \valid(c+4); + break; + case 6: + //@ assert (char )p < c; + break; + case 7: + //@ assert p <= (int)1; + break; + case 8: + //@ assert (int)p == 3; + break; + case 9: + //@ assert (int)p != 3; + break; + case 10: + //@ assert \exists int x ; x != 0 ==> p == x; + break; + case 11: + //@ assert \forall int x ; \true; + break; + case 12: + //@ assert \valid((long long )5); + break; + case 13: + //@ assert \valid(p); + break; + case 14: + //@ assert (\valid((char)5)); + break; + } + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/anonymous_field.i frama-c-20111001+nitrogen+dfsg/tests/misc/anonymous_field.i --- frama-c-20110201+carbon+dfsg/tests/misc/anonymous_field.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/anonymous_field.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +struct { + int a ; + struct { + int gcc_a ; + int gcc_b ; + } ; + int b ; +} Sa ; + +//@ ensures Sa.gcc_a == Sa.a && Sa.gcc_b == Sa.b; +void set_anonymous_struct (void) { + Sa.gcc_a = Sa.a ; + Sa.gcc_b = Sa.b ; +} + +int main () { + Sa.a = 42; + Sa.b = 3; + set_anonymous_struct(); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/arch.i frama-c-20111001+nitrogen+dfsg/tests/misc/arch.i --- frama-c-20110201+carbon+dfsg/tests/misc/arch.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/arch.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +int a,b,c; +unsigned long l; +int t[10]; + +void main(void) +{ + l = (unsigned long)t; + a = sizeof(int); + b = sizeof(long); + c = sizeof(int); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/arg_array.i frama-c-20111001+nitrogen+dfsg/tests/misc/arg_array.i --- frama-c-20110201+carbon+dfsg/tests/misc/arg_array.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/arg_array.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,8 @@ +void main(int ptr, int T[4]) { + T=0; + ptr = T; + ptr[1]=1; + 2[ptr] = 2; + T=T; + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/array_bounds.i frama-c-20111001+nitrogen+dfsg/tests/misc/array_bounds.i --- frama-c-20110201+carbon+dfsg/tests/misc/array_bounds.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/array_bounds.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +/* run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -unsafe-arrays -val -deps -out -input -journal-disable +/ + +struct { int a; int T[5]; int b; } s = {1,0,1,2,3,4,5}; + +void main(int c) { + s.a = 9; + s.b = 9; + for(int i=0; i+5<=10; i++) {s.T[i] = c;} + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/array_degenerating_loop.i frama-c-20111001+nitrogen+dfsg/tests/misc/array_degenerating_loop.i --- frama-c-20110201+carbon+dfsg/tests/misc/array_degenerating_loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/array_degenerating_loop.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +int t[100]={1,1}; + + +void main(int arg) +{ + int G=55; + int i; + for (i=0; i<=arg; i++) + G += t[i]; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/array_loop.i frama-c-20111001+nitrogen+dfsg/tests/misc/array_loop.i --- frama-c-20110201+carbon+dfsg/tests/misc/array_loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/array_loop.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +int t[20]={17,18,19,20,21,22,23,24,1,1,1,1,1,1,1,1,1,1}; +int tt[20]={17,18,19,20,21,22,23,24,1,1,1,1,1,1,1,1,1,1}; + +void main(void) +{ + int i; + for (i=0; i<=15; i++) + t[i/2] = -i+tt[i]; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/array_overlap.i frama-c-20111001+nitrogen+dfsg/tests/misc/array_overlap.i --- frama-c-20110201+carbon+dfsg/tests/misc/array_overlap.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/array_overlap.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,20 @@ +char T[10]={1,1,1,2,2,3,0}; +char U[10]={1,1,1,2,2,3,0}; + +struct S { char t[6]; }; + + +void main (int c) { + + struct S ptr; + ptr = &T[1]; + ptr = (struct S)(&T[0]); + + {int i; + if (c) i = 0; else i = 1; + ptr = &U[i]; + ptr = (struct S)(&U[0]); + + } + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/array_ptr.i frama-c-20111001+nitrogen+dfsg/tests/misc/array_ptr.i --- frama-c-20110201+carbon+dfsg/tests/misc/array_ptr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/array_ptr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +int G = 1; + +typedef int param_check[20]; + +int f(param_check x) { + G=(x)[0]; + (**x)[0] = 2; +} + +param_check l={1}; + +int main() { + int g = &l; + f(&g); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/array_zero_length.i frama-c-20111001+nitrogen+dfsg/tests/misc/array_zero_length.i --- frama-c-20110201+carbon+dfsg/tests/misc/array_zero_length.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/array_zero_length.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -lib-entry -main main -journal-disable +/ + +char T[]; + +void main() { + T[2]= 3; + T[1] = T[3] +3; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/assert_ptr.i frama-c-20111001+nitrogen+dfsg/tests/misc/assert_ptr.i --- frama-c-20110201+carbon+dfsg/tests/misc/assert_ptr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/assert_ptr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +int ptr, **q, s_q, a, r; + +int main(int c, int d, int e) +{ + q = &s_q; + if (c) ptr = &a; + if (d) q = (&a + e) ; + /@ assert ptr == 0 || ptr != 0 ; / + Frama_C_show_each_ptr(ptr); + if (ptr != 0) (ptr)++; + + /@ assert q != 0 ; / + Frama_C_show_each_q(s_q); + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/assigns.i frama-c-20111001+nitrogen+dfsg/tests/misc/assigns.i --- frama-c-20110201+carbon+dfsg/tests/misc/assigns.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/assigns.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + OPT: -memory-footprint 1 -journal-disable -main F2 -lib-entry -out +/ + +int G; + +//@ assigns s[..]; +void F1(char s); + +char T[100]; + +void F2(int c) +{ + if (c) F1(T); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/automalloc.i frama-c-20111001+nitrogen+dfsg/tests/misc/automalloc.i --- frama-c-20110201+carbon+dfsg/tests/misc/automalloc.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/automalloc.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +typedef unsigned int size_t; +voidmalloc(size_t s); +voidrealloc(voidptr,size_t s); +voidalloca(size_t s); +void free (void * ptr); +voidcalloc (size_t nmemb, size_t size); + +void main(int test) { + char buf=0; + if (test) buf = (char)malloc(sizeof(char)5); + else buf = (char)realloc(&test,sizeof(char)6); + + if (test) buf[1] = 16; + + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bad_loop.i frama-c-20111001+nitrogen+dfsg/tests/misc/bad_loop.i --- frama-c-20110201+carbon+dfsg/tests/misc/bad_loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bad_loop.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +volatile int c; +void main () { + int x; volatile int d=0,e=0; + x = 2; + + while(1) { + L1: if (c) goto FIN; + if (d) goto L2; + x = 0; + } + + while (1) { + L2: if (c) break; + if (e) goto L1; + x=1; + } + + FIN: ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/behavior_names.i frama-c-20111001+nitrogen+dfsg/tests/misc/behavior_names.i --- frama-c-20110201+carbon+dfsg/tests/misc/behavior_names.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/behavior_names.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +/* run.config + OPT: -load-script tests/misc/behavior_names.ml +/ + +/@ behavior foo: ensures \true; / +void f () { + int x = 0; + /@ behavior bar: ensures \true; / + x++; + if (x) { /@ behavior bli: ensures \true; / x++; } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bigarray.c frama-c-20111001+nitrogen+dfsg/tests/misc/bigarray.c --- frama-c-20110201+carbon+dfsg/tests/misc/bigarray.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bigarray.c 2011-10-10 08:39:03.000000000 +0000 @@ -2,9 +2,9 @@ const int T[SIZE]={2,3}; const charS = "uututututututu"; -int main() { +int main(int c) { int i; - (char)S = 'E'; + if (c) (char)S = 'E'; for(i=0; i < SIZE/4; i++) (int)&T[i] = 1; for(i=0; i< SIZE/8; i++) diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bitfield_assign.i frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield_assign.i --- frama-c-20110201+carbon+dfsg/tests/misc/bitfield_assign.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield_assign.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,36 @@ +int g_18; + +typedef unsigned int uint32_t; +typedef int int32_t; +typedef short int16_t; +typedef long long int64_t; + +struct S0 { + uint32_t f0; + int16_t f1; + signed f2 : 26; + int64_t f3; +}; + +union U3 { + signed f0 : 7; + int32_t f1; + int32_t f2; + struct S0 f3; +}; + +static union U3 g_7[1] = {{0x00868BB4L}}; + +int g_5; +int g_2; + +void Frama_C_show_each(unsigned); + +main(){ + unsigned short l_8 = 1UL; + unsigned int l_16 = 0xBD4AA41AL; + + g_2 |= (g_7[g_5].f3.f2 = l_16); + Frama_C_show_each(g_2); +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bitfield.i frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield.i --- frama-c-20110201+carbon+dfsg/tests/misc/bitfield.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,68 @@ +struct t1 { unsigned int a:2; int b:4; int c:22;int d:32;} h; +struct t2 { unsigned int a:2; int b:4; int c:22; int d;} k,k8,kr8; + +struct t3 { int b:16; } ll; + +struct t1 ini = { 14, -55, 99999 } ; + +unsigned int VV=55; + +unsigned short q4 = 40000; + +int X; + +void f(int x) +{ + X=x; + Frama_C_dump_each(); +} + +int return_8(void) +{ + return 8; +} + +struct S { unsigned f:32; signed sf:32; } x = { 28349, 28349}; +unsigned short us = 0xDC23L; +int G,H; +int g(void) { + int r = (x.f ^ ((short)-87)) >= us; + H = (x.sf ^ ((short)-87)) >= us ; + return r; +} + +union U1 { + int f0 ; + int f1 : 15 ; +}; + +int main (int a, int b){ + struct t1 v,w; + + union U1 l_161; + l_161.f0 = (int)-1L; + Frama_C_show_each(1); + if ((!l_161.f0) <= l_161.f1) + Frama_C_show_each(2); + else + Frama_C_show_each(3); + + VV = h.a; + + h.a = VV; + + v.c = &v; + v.d = &v + 1; + v.d = v.d + 1; + v.a = 4; + v.b = 7; + f(v.b); + h.b = a+b + h.a + h.b; + h.c = &v +1; + + k8.b = 8; + kr8.b = return_8(); + + ll.b = q4; + G=g(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bitfield_longlong.c frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield_longlong.c --- frama-c-20110201+carbon+dfsg/tests/misc/bitfield_longlong.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield_longlong.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,33 @@ +/* run.config + OPT: -memory-footprint 1 -val -cpp-command "gcc -C -E -Dprintf=Frama_C_show_each" -journal-disable +/ +struct X50 { + long long int z:50; +} s50 = { 2 }; + +struct X10 { + long long int z:10; +} s10 = { 2 }; + + +struct U32 { + unsigned long z:32; +} u32 = { -1 }; + +struct S32 { + signed long z:32; +} s32 = { -1 }; + + +int main() { + int x = u32.z >=0; + int y = s32.z >=0; + printf("%zu %zu %zu %zu\n", + sizeof(long long int), + sizeof(s10.z+0), + sizeof(s50.z+0), + sizeof(u32.z+0) + ); + printf("%d %d\n", x, y); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bitfield_receives_result.i frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield_receives_result.i --- frama-c-20110201+carbon+dfsg/tests/misc/bitfield_receives_result.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bitfield_receives_result.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +struct S { int b:31; } s; + +int f(void) +{ + return -1; +} + +main(){ + s.b = f(); + Frama_C_dump_each(); +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bitwise_or.i frama-c-20111001+nitrogen+dfsg/tests/misc/bitwise_or.i --- frama-c-20110201+carbon+dfsg/tests/misc/bitwise_or.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bitwise_or.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,26 @@ +/ run.config + OPT: -memory-footprint 1 -val -journal-disable share/builtin.c +/ +#include "../../share/builtin.h" + +int or1, or2, or3, or4, or5; +int and1, and2, and3, and4, and5; +unsigned int uand1, uand2, uand3, uand4, uand5; +int a,b,c,d,e; + +main(){ + a = Frama_C_interval(3,17); + b = Frama_C_interval(-3,17); + c = Frama_C_interval(13,27); + or1 = a | b; + or2 = a | c; + or3 = b | c; + + and1 = a & b; + and2 = a & c; + and3 = b & c; + + uand4 = 0xFFFFFFF8U & (unsigned int) c; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bitwise_pointer.i frama-c-20111001+nitrogen+dfsg/tests/misc/bitwise_pointer.i --- frama-c-20110201+carbon+dfsg/tests/misc/bitwise_pointer.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bitwise_pointer.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,25 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -inout -journal-disable +/ + +char t[100]={0,1,2,3,4,5,6,7,8,9}; +char p; +int x; + +char t1[100]={0,1,2,3,4,5,6,7,8,9}; +char p1; +int x1; + +void main(void) +{ + int mask = 7; + + p = (char)(((int)(t + 7)) & ~7); + p = 5; + x = p; + + p1 = (char)(((int)(t1 + mask)) & ~mask); + p1 = 5; + x1 = p1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/biz.i frama-c-20111001+nitrogen+dfsg/tests/misc/biz.i --- frama-c-20110201+carbon+dfsg/tests/misc/biz.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/biz.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f2 -journal-disable +/ + +int p, q, G = 0; + +void f2() { + p = &G; + (((char)p)++) = 3; // specific test for biz.c:5: error: invalid lvalue in increment +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bool.c frama-c-20111001+nitrogen+dfsg/tests/misc/bool.c --- frama-c-20110201+carbon+dfsg/tests/misc/bool.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bool.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -#include<stdbool.h> -bool x; -int y; - -int main() { - x=false; - printf("%d\n",x); - x=2; - printf("%d\n",x); - y=x+1; - printf("%d,%d\n",x,y); - x=x+1; - printf("%d\n",x); - x=x+1; - printf("%d\n",x); - return y; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bool.i frama-c-20111001+nitrogen+dfsg/tests/misc/bool.i --- frama-c-20110201+carbon+dfsg/tests/misc/bool.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bool.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +/ run.config + STDOPT: +"-print" +/ +_Bool x; +int y; + +int main() { + x=0; + printf("%d\n",x); + x=2; + printf("%d\n",x); + y=x+1; + printf("%d,%d\n",x,y); + x=x+1; + printf("%d\n",x); + x=x+1; + printf("%d\n",x); + return y; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/branch2.i frama-c-20111001+nitrogen+dfsg/tests/misc/branch2.i --- frama-c-20110201+carbon+dfsg/tests/misc/branch2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/branch2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ + unsigned short i; + unsigned short etat_to; + signed short changepage; + int plein,NumFonct,NumSsPage; +void main(void) +{ + + + plein = 1; + / 0 / if(changepage != 0) + { + NumFonct = 0 ; + } else {} + while ( NumSsPage <= 0 ) + { + NumSsPage = NumSsPage + (unsigned short)9; + } + + + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/branch.i frama-c-20111001+nitrogen+dfsg/tests/misc/branch.i --- frama-c-20110201+carbon+dfsg/tests/misc/branch.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/branch.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +int a, b,c,d,e; +void main() +{ + L: a=0; + if (c) goto L2; + L3: b=0; + goto L; + L2: d=0; + if (d) goto L; + if (e) goto L4; + goto L3; + L4: return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/broken_loop.i frama-c-20111001+nitrogen+dfsg/tests/misc/broken_loop.i --- frama-c-20110201+carbon+dfsg/tests/misc/broken_loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/broken_loop.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main loop -journal-disable +/ +int X; + +void loop(int d) { + + if(d) ; else ; + goto L; + X=0; + if(d) X=1; else L:; + X=2; + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0442-2.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0442-2.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0442-2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0442-2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,7 @@ +/ run.config +OPT: -print -check tests/misc/bts0442.i +/ +enum E { E0=0, E1=1} ve1=E1; +void f (void) { + ve1=E0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0442.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0442.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0442.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0442.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,4 @@ +/ run.config +OPT: -print -check tests/misc/bts0442-2.i +/ +enum E { E1=1, E2=2} ve2=E2; diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0451.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0451.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0451.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0451.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,28 @@ +/ run.config + COMMENT: running this test fails on purpose + OPT: -simplify-cfg -typecheck + / + +/ small test cases to verify that break is accepted in while and switch / +int f () { + + while (1) { + if (0) { + while (1) break; + } + switch (3) { + case 0: return 5; + default: + if (1) break; else break; + } + break; + } + + return 0; +} + +/ should abort with an error at type-checking / +int main (void) { + break; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0452.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0452.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0452.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0452.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,88 @@ +/ run.config + OPT: -typecheck -load-script tests/misc/bts0452.ml +/ + +/ must emit falls-through warning. */ +int f (int foo, char** args) { + switch(foo) { + case 1: + return 0; + break; + + default: + if (foo) return 1; + } +} + +/* must emit falls-through warning. */ +int h (int foo, char** args) { + switch(foo) { + case 1: + return 0; + break; + + default: + { if (foo) goto L ; + return 1; + L: break; } + } +} + +/* must NOT emit falls-through warning. */ + +int g (int foo, char** args) { + switch(foo) { + case 1: + return 0; + break; + + default: + if (foo) return 1; else return 2; + } +} + +/* must NOT emit falls-through warning. */ +int k (int foo, char** args) { + switch(foo) { + case 1: + return 0; + break; + + default: + { goto L ; + break; + L: return 0; } + } +} + +/* must NOT emit falls-through warning. */ +int l (int foo, char** args) { + switch(foo) { + case 1: + return 0; + break; + + default: + { L: goto L ; + break; + } + } +} + +/* must NOT emit falls-through warning */ +int main (int foo, char** args) { + switch(foo) { + case 1: + return 0; + break; + + default: + return 1; + } +} + +/* must NOT emit falls-through warning */ +int m (int foo, char** args) { + if (foo >= 0 && foo <=10) { return 0; } else { return 1; } + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0489.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0489.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0489.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0489.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,109 @@ +/* run.config + OPT: -load-script tests/misc/bts0489.ml +/ + +typedef unsigned int uint8_t; +typedef int int8_t; +typedef unsigned int uint16_t; +typedef int int16_t; +typedef int int32_t; +typedef unsigned int uint32_t; + +void foo1(uint8_t x) {}; + +int16_t t1(void) +{ + uint8_t u8a, u8b, u8c; + int8_t s8a, s8b; + uint16_t u16a; + int16_t s16a; + int32_t s32a; + float f32a; + double f64a; + foo1(u8a); / compliant / + foo1(u8a + u8b); / compliant / + foo1(s8a); / not compliant / + foo1(u16a); / not compliant / + foo1(2); / not compliant / + foo1(2U); / compliant / + foo1((uint8_t)2); / compliant / + /... s8a + u8a /* not compliant / + /... s8a + (int8_t)u8a /* compliant / + s8b = u8a; / not compliant / + /... u8a + 5 /* not compliant / + /... u8a + 5U /* compliant / + /... u8a + (uint8_t)5 /* compliant / + u8a = u16a; / not compliant / + u8a = (uint8_t)u16a; / compliant / + u8a = 5UL; / not compliant / + /... u8a + 10UL /* compliant / + u8a = 5U; / compliant / + /... u8a + 3 /* not compliant / + /... u8a >> 3 /* compliant / + /... u8a >> 3U /* compliant / + + /... s32a + 80000 /* compliant / + /... s32a + 80000L /* compliant / + f32a = f64a; / not compliant / + f32a = 2.5; / not compliant - + unsuffixed floating + constants are of type + double / + u8a = u8b + u8c; / compliant / + s16a = u8b + u8b; / not compliant / + s32a = u8b + u8c; / not compliant / + f32a = 2.5F; / compliant / + u8a = f32a; / not compliant / + s32a = 1.0; / not compliant / + s32a = u8b + u8c; / not compliant / + f32a = 2.5F; / compliant / + u8a = f32a; / not compliant / + s32a = 1.0; / not compliant / + f32a = 1; / not compliant / + f32a = s16a; / not compliant / + /... f32a + 1 /* not compliant / + /... f64a * s32a /* not compliant / + /.../ + return (s32a); / not compliant / + /.../ + return (s16a); / compliant / + /.../ + return (20000); / compliant / + /.../ + return (20000L); / not compliant / + /.../ + return (s8a); / not compliant / + /.../ + return (u16a); / not compliant / +}; + +int16_t foo2(void) +{ + uint8_t u8a, u8b; + int8_t s8a; + uint16_t u16a,u16b; + int16_t s16a,s16b; + int32_t s32a,s32b; + uint32_t u32a; + float f32a,f32b; + double f64a,f64b ; + + /... (u16a + u16b) + u32a /* not compliant / + /... s32a + s8a + s8b /* compliant / + /... s8a + s8b + s32a /* not compliant / + f64a = f32a + f32b; / not compliant / + f64a = f64b + f32a; / compliant / + f64a = s32a / s32b; / not compliant / + u32a = u16a + u16a; / not compliant / + s16a = s8a; / compliant / + s16a = s16b + 20000; / compliant / + s32a = s16a + 20000; / not compliant / + s32a = s16a + (int32_t)20000; / compliant / + u16a = u16b + u8a; / compliant / + foo1(u16a); / not compliant / + foo1(u8a + u8b); / compliant / + /.../ + return s16a; / compliant / + /.../ + return s8a; / not compliant / +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0489.ml frama-c-20111001+nitrogen+dfsg/tests/misc/bts0489.ml --- frama-c-20110201+carbon+dfsg/tests/misc/bts0489.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0489.ml 2011-10-10 08:39:03.000000000 +0000 @@ -8,7 +8,7 @@ | Const(CInt64 (_,_,Some s)) -> Format.printf "Found representation %s@." s; Cil.SkipChildren | Const(CInt64(n,_,None)) -> - Format.printf "No representation for %s@." (Int64.to_string n); + Format.printf "No representation for %s@." (My_bigint.to_string n); Cil.SkipChildren | _ -> Cil.DoChildren end diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0506.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0506.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0506.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0506.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +/run.config +STDOPT: +"-no-collapse-call-cast" +"-print" +STDOPT: +"-collapse-call-cast" +"-print" +/ + +int f(int x) { return x+1; } + +int main () { + short x = 4; + x = f(42); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0525-2.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0525-2.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0525-2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0525-2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +/ run.config + OPT: -typecheck -check tests/misc/bts0525.i +/ + +typedef enum {E1=2, E2} T_EN1 ; + +int f2(T_EN1 p2) +{ + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0525.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0525.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0525.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0525.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +/ run.config + OPT: -check tests/misc/bts0525-2.i +/ +typedef enum {E3=2, E4} T_EN2 ; +typedef enum {E1=2, E2} T_EN1 ; + +int f1(T_EN1 p1) +{ + if (p1==E1) return 1; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0577.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0577.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0577.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0577.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,6 @@ +/run.config +OPT: -print +/ +typedef enum { E1_a, E1_b, E1_c } E1; +typedef enum { E2_a = E1_a, E2_b } E2; +int f (E2 e) { return e; } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0588.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0588.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0588.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0588.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +/ run.config + OPT: -print -check +/ + +//@ requires x>=0; +void g(int x); + +void g(int a) { + return; +} + +void f(int a){ a=1;} +//@ ensures x>0; +void f(int x); diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0769.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0769.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0769.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0769.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +/ run.config + OPT: -print -check +/ + +struct s { + struct {int ui;} _; + union foo { int ii; }; +} S; + +int main(){ + return S._.ui + S.ii; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0775.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0775.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0775.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0775.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,4 @@ +main(){ + int r = 0xE2DB80EBBD4856CDLL >= 1; + return r; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0858.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts0858.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts0858.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0858.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +typedef long int64_t; +typedef unsigned long uint64_t; + + +int main() { + uint64_t tmp = 18446744073709551615UL ; + if (0xffffffffUL == tmp) + return 1; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts0916.c frama-c-20111001+nitrogen+dfsg/tests/misc/bts0916.c --- frama-c-20110201+carbon+dfsg/tests/misc/bts0916.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts0916.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + OPT: -keep-comments -print +/ +/ Use frama-c with option -keep-comments / + +void main() { + int port=10; + + while (port-->0) // ( port & 0x80 ) == 0 ) + { + ; / wait for pin1 - Compliant/ + / wait for pin2 / ; / Not compliant/, comment before ; / + ;/* wait for pin3 - Not compliant, no white-space char after ; / + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bts59.i frama-c-20111001+nitrogen+dfsg/tests/misc/bts59.i --- frama-c-20110201+carbon+dfsg/tests/misc/bts59.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bts59.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +/run.config + OPT: -print -journal-disable + / +float g() +{ + double retres=2; + int first = 6; + + { int first = 5 ; + return retres; + } + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/buffer_overflow.i frama-c-20111001+nitrogen+dfsg/tests/misc/buffer_overflow.i --- frama-c-20110201+carbon+dfsg/tests/misc/buffer_overflow.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/buffer_overflow.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,24 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -ulevel 15 -journal-disable +/ +int main(int argc, char argv[]) +{ + int test_value; + int loop_counter; + char buf[10]; + + test_value = 17; + + loop_counter = 0; + while(++loop_counter) + { + /* BAD / + buf[loop_counter] = 'A'; + if (loop_counter >= test_value) break; + } + + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bug0223.i frama-c-20111001+nitrogen+dfsg/tests/misc/bug0223.i --- frama-c-20110201+carbon+dfsg/tests/misc/bug0223.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bug0223.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,36 @@ +/ run.config +STDOPT: +"-unspecified-access" +STDOPT: +"-no-unspecified-access" +/ + +// No warning should be raised: we can syntactically ensure that +// the order of evaluation of expressions does not matter here. + +extern int F(int, int); + +extern int my_strcnmp(const char const s1, const char * const s2, int +n); +extern char ch1, ch2; +void h2(void) { + int test; + test = (my_strcnmp(&ch1[3],&ch2[3],12) == 0) ; +} + +extern unsigned char get(unsigned int); + +extern void set(unsigned int ); + +void ptr_deref(unsigned int const ui) { + unsigned int s=0; + set(&s); + ui+=get(s) ; +} + +void main() +{ + int i=0, j=0, k=0, l; + int p = &j; + l = (F(i,j) == k); + p = (F(p,j) == k); + h2(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bug_023.i frama-c-20111001+nitrogen+dfsg/tests/misc/bug_023.i --- frama-c-20110201+carbon+dfsg/tests/misc/bug_023.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bug_023.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +int i; +int x; + +int f(); + +int main() { + if (i == 0 || i == 1) { + i += f(); + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bug_0244.i frama-c-20111001+nitrogen+dfsg/tests/misc/bug_0244.i --- frama-c-20110201+carbon+dfsg/tests/misc/bug_0244.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bug_0244.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +int R,p; + +void main(void) +{ + int a,i; + a=2; + for(i=0; i<2; i++) + { + int u=a; + p = &u; + } + R = p; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bug0245.i frama-c-20111001+nitrogen+dfsg/tests/misc/bug0245.i --- frama-c-20110201+carbon+dfsg/tests/misc/bug0245.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bug0245.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,26 @@ +/* run.config + STDOPT: +"-slevel 3" +/ +int R,p,S,q; + +void main(int c, int d) +{ + int a,i; + a=2; + p = q = &a; + for(i=0; i<2; i++) + { + int u=a; + p = &u; + toto: + { + int v; + v = 3; + v++; + q = &v; + } + } + if (c) R = p; + if (d) S = q; + //if (a-a) goto toto; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bug0277.i frama-c-20111001+nitrogen+dfsg/tests/misc/bug0277.i --- frama-c-20110201+carbon+dfsg/tests/misc/bug0277.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bug0277.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +/ run.config + OPT: -typecheck + / +typedef enum { + DGI_ID_NB = 56 +} T_DGI_ID; + + + +const int T[DGI_ID_NB] = { 3 } ; + + + +/@ + +requires P : T[0]==3 + ; + + +/ +void main() ; diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/bug.i frama-c-20111001+nitrogen+dfsg/tests/misc/bug.i --- frama-c-20110201+carbon+dfsg/tests/misc/bug.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/bug.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable +/ + +void f(unsigned short typemess) +{ + + unsigned short i; + unsigned short nbpompe; + unsigned short bitx; + + if (typemess == (unsigned short)0 ) + { + + goto L; + + goto L; + } + L:; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/call_2.i frama-c-20111001+nitrogen+dfsg/tests/misc/call_2.i --- frama-c-20110201+carbon+dfsg/tests/misc/call_2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/call_2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,30 @@ +int G = 0; +int H; + +int f (int x) { + G = x; + return 0; +} + +int i_auCyc () { + f(0); + G=17; + if (H) f(2); + else f(5); + f(6); + return 0; +} + +extern void fp (intp); + +int G,x; +void main() { + x = 1; + G = 0; + while (x) { + G ++; + } + + +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/call_3.i frama-c-20111001+nitrogen+dfsg/tests/misc/call_3.i --- frama-c-20110201+carbon+dfsg/tests/misc/call_3.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/call_3.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,18 @@ +int GG; + +int f (void) +{ int G; + G = 2; + GG = 3; + return 1; } + + +int main (void) +{ int lm = 77; + + int res_f = f(); + GG = lm; + + return 0; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/call_alias.i frama-c-20111001+nitrogen+dfsg/tests/misc/call_alias.i --- frama-c-20110201+carbon+dfsg/tests/misc/call_alias.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/call_alias.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,34 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main main0 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main2 -journal-disable +/ + +int X,c,u,v,w,G; + +int incr(int a,int* b) { + (a)++; + (b)++; + return a+b; +} + + +int sum(int a,int b) { + return a+b; +} + +int G=0,H=0,I=0; +int main0 () { + I=incr(&G,&H); + return I; +} + +int main1 () { + I=incr(&G,&G); + return I; +} + +int main2() { + I = sum(G,H); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/call_deep.i frama-c-20111001+nitrogen+dfsg/tests/misc/call_deep.i --- frama-c-20110201+carbon+dfsg/tests/misc/call_deep.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/call_deep.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,35 @@ +int R=77; +int G; +int* pG; +int F0; +int f0(int p0) { + F0 = R; + p0 = R; + return R; +} + +int F1; + +int f1(intpp1) { + F1 = R; + pp1 = R; + *pp1 = pG; + f0(pG); + return **pp1; +} + +int H,XX; +int Fmain; + +#pragma no_return ("Pre a : H==0;") +int main() { + int *ph; + int **pph; + pG = &G; + ph = &H; + pph = &ph; + Fmain = f1(pph); + XX=0; + return 0; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/call.i frama-c-20111001+nitrogen+dfsg/tests/misc/call.i --- frama-c-20110201+carbon+dfsg/tests/misc/call.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/call.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,64 @@ +int p[10],q[10]; +int r; + +int res; + +void f(intt) { + res = (t+5); +} + +void leaf_fun_int(int x); +void leaf_fun_charp(char x); + +/* @ + @ assigns \result , p[c] \from p[c..(c+3)], p[], p[2]; + @ assigns q[5] \from p[1], c ; + @/ +void main(int c, char **v) +{ + if (c&1) leaf_fun_int(v[2]); + if (c&2) leaf_fun_char(v[2]); + int lcount= 0; + res= 1111; + for (lcount=0; lcount<=6; lcount++) + { + p[lcount]=lcount; + q[lcount]=lcount+10;}; + + p[5] = 177; + q[5] = 188; + + int tmp ; + { + if (c&4) { + tmp = p; + } else { + tmp = q; + } + + f(tmp); // t --> deps(tmp) + + } +} + +struct A {int a; int b;} x; + +void f_struct(struct A y) { + res = y.b; +} + +void caller_struct() { + struct A z = res?x:x; + f_struct(z); + +} + + +void f_ptr(intX) { + res = X; +} +void caller_ptr() { + int e = res?&x.a:&x.b; + f_ptr(e); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/call_multi.i frama-c-20111001+nitrogen+dfsg/tests/misc/call_multi.i --- frama-c-20110201+carbon+dfsg/tests/misc/call_multi.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/call_multi.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,30 @@ +/* run.config + STDOPT: +"-unspecified-access" +/ +int uppol2(int al1,int al2,int plt,int plt1,int plt2) +{ + long int wd2,wd4; + int apl2; + + wd2 = 4L(long)al1; + if((long)pltplt1 >= 0L) wd2 = -wd2; / check same sign / / CONDITION / + wd2 = wd2 >> 7; / gain of 1/128 / +// CEA_TEST(plt,plt2,(long)pltplt2>= 0L); + if((long)pltplt2 >= 0L) { / CONDITION / + wd4 = wd2 + 128; / same sign case / + } + else { + wd4 = wd2 - 128; + } + apl2 = wd4 + (127L(long)al2 >> 7L); /* leak factor of 127/128 / + printf("GOT:%d\n",wd4); + return(apl2); +} + +int G; +void main() { + G += uppol2(0,0,0,0,0); + G += uppol2(0,0,-1,1,0); + G += uppol2(0,0,-1,2,2); + G += uppol2(0,0,0,3,0); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/call_simple.i frama-c-20111001+nitrogen+dfsg/tests/misc/call_simple.i --- frama-c-20110201+carbon+dfsg/tests/misc/call_simple.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/call_simple.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,17 @@ +int X,c,u,v,w,G; + +void f(int a,int b,int c) { + int i=a; + i = 0; + a = 0; + X = a+b+c; +} + +int main (int ll) { + u = 3; + v = G; + w = 17; + f(&u,v,w); + c = ll++; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/callsite.i frama-c-20111001+nitrogen+dfsg/tests/misc/callsite.i --- frama-c-20110201+carbon+dfsg/tests/misc/callsite.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/callsite.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,35 @@ +/* run.config + OPT: -debug 1 -load-script tests/misc/callsite.ml + / + +void f(void); +void g(void); +void h(void); +void k(void); + +void f(void) +{ + g(); + h(); + g(); +} + +void g(void) +{ + h(); + k(); + h(); +} + +void h(void) +{ + k(); + k(); +} + +// Should have 8 call sites: +// CallSites of f : - +// CallSites of g : From f(2) +// CallSites of h : From f(1) + From g (2) +// CallSites of k : From g(1) + From h (2) + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/callsite.ml frama-c-20111001+nitrogen+dfsg/tests/misc/callsite.ml --- frama-c-20110201+carbon+dfsg/tests/misc/callsite.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/callsite.ml 2011-10-10 08:39:03.000000000 +0000 @@ -3,8 +3,9 @@ let dump f = let kf = Globals.Functions.find_by_name f in let csites = Kernel_function.find_syntactic_callsites kf in - Log.print_on_output "Call Sites for %s:@\n%t" f + Log.print_on_output (fun fmt -> + Format.fprintf fmt "Call Sites for %s:@\n" f ; List.iter (fun (ckf,stmt) -> Format.fprintf fmt " - From %s at #%03d@\n" diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/case_analysis.i frama-c-20111001+nitrogen+dfsg/tests/misc/case_analysis.i --- frama-c-20110201+carbon+dfsg/tests/misc/case_analysis.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/case_analysis.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +/ run.config + OPT: -memory-footprint 1 -val -slevel 30 -journal-disable -float-normal + OPT: -memory-footprint 1 -val -slevel 30 -journal-disable -float-normal -all-rounding-modes +/ + +int sq,s; + +float rq,r; + +void main(int c) +{ + s = (c >= -10) ? ((c <= 10) ? c : 0) : 0; + r = s; + //@ assert s >= 0 || s < 0 ; + sq = s s; + + //@ assert r >= 0.0 || r < 0.0 ; + rq = r * r; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cast1.i frama-c-20111001+nitrogen+dfsg/tests/misc/cast1.i --- frama-c-20110201+carbon+dfsg/tests/misc/cast1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cast1.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,28 @@ +short si=0; +int i=0; +int S[5]={1}; +int I[5]={1}; + +void main(void) { + for (si=0;si<2;si++) S[i]=2; + for (i=0;i<2;i++) I[i]=2; +} + + +void with_if () +{ + long x; + short si=x?0:2; + + if ((unsigned short)si < 2) x=si; else x=3; + +} + +void with_if2 () +{ + long x; + short si=x?0:4; + + if ((signed short)si < 2) x=si; else x=3; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cast2.i frama-c-20111001+nitrogen+dfsg/tests/misc/cast2.i --- frama-c-20110201+carbon+dfsg/tests/misc/cast2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cast2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main g -journal-disable +/ + +extern int any_int(void); + +void g() { + int t; + unsigned int G; + t = any_int(); + G = t; + t = t+1; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cast3.i frama-c-20111001+nitrogen+dfsg/tests/misc/cast3.i --- frama-c-20110201+carbon+dfsg/tests/misc/cast3.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cast3.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,5 @@ +unsigned char G = (unsigned char)(-1); + +void main (void) { + G = -255; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cast_hetero.i frama-c-20111001+nitrogen+dfsg/tests/misc/cast_hetero.i --- frama-c-20110201+carbon+dfsg/tests/misc/cast_hetero.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cast_hetero.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,17 @@ +int X; +intpt; +void f(int c) { + pt = &X; + pt = c; +} + +int T[10]={0}; + +void g(int c){ + pt = &X; + T[X] = c; +} + +void main() { + g(1); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cast.i frama-c-20111001+nitrogen+dfsg/tests/misc/cast.i --- frama-c-20110201+carbon+dfsg/tests/misc/cast.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cast.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,78 @@ +char X= "NULL"; +void MC3_COM_ARRET_68040(int i , char c, int j) { + X = c; +} + +static void MC3_ANALYSER_CPTRENDU(int n , char num_station , + short cptrendu ) +{ + + MC3_COM_ARRET_68040(160, (char )"mc3_mdb_emi_act.c", 506); + +} + + +int G,H,K,L,i,b; +unsigned int I; +signed char c,d,e; +unsigned char uc,ud; +long long ll,gg; +unsigned long long ull, ugg; + + +int any_int(void) +{ volatile int i = 0; + int j; + i =(int)0 + i; + return (i/4);}; + +void all_cast() { + G=258; + H=any_int(); + + if (H>=258) {if (H<=268) {G = H;};}; + G = G&128?0xFFFFFF00|(G&255):(G&255); + G = (signed char)G; // 2..12 + + K=-10; + if (H>=-10) {if (H<=20) {K = H;};}; + c = (signed char)(K); // -10..20 + uc = c ; // (signed char)(K); // 0..255 + + K = c; + I = (unsigned int)(signed char)(int)(-1); + printf("%ud\n",I); + + L=-19; + if (H>=-2000) {if (H<=-10) {L = H;}} + d = L; // top + ull=1; + L=0; + if (H>=-2000) {if (H<=1) {L = 2H;}} + e = L; // top + +} + +int main(void) +{ + int min = 130; + int max = 135; + int i; + int G; + for (i=min; i<=max; i++) + { + G = i&128?0xFFFFFF00|(i&255):(i&255); + printf("cast:%d formule:%d\n",(int)(signed char) i,G); + } + printf("usc: %ud",(unsigned int)(signed char)(int)(-1)); +} + + +void f() { + G=258; + if (H>=258) {if (H<=268) {G = H;};}; + I = (unsigned char)G; // = 2..12 + +} + +//int main(){all_cast();} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cert_exp35_c.i frama-c-20111001+nitrogen+dfsg/tests/misc/cert_exp35_c.i --- frama-c-20110201+carbon+dfsg/tests/misc/cert_exp35_c.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cert_exp35_c.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,34 @@ +struct X { char a[6]; }; + +struct X addressee(void) { + struct X result = { "world" }; + return result; +} + +int main(void) { + printf("Hello, %s!\n", addressee().a); + return 0; +} + +/* +From https://www.securecoding.cert.org/confluence/display/seccode/EXP35-C.+Do+not+access+or+modify+an+array+in+the+result+of+a+function+call+after+a+subsequent+sequence+point + +This solution is problematic because of three inherent properties of C: + +In C, the lifetime of a return value ends at the next sequence point. +Consequently by the time printf() is called, the struct returned by +the addressee() call is no longer considered valid, and may have been +overwritten. +C function arguments are passed by value. As a result, copies are made +of all objects generated by the arguments. For example, a copy is made of the +pointer to "Hello, %s!\n". Under most circumstances, these copies protect you +from the effects of sequence points described earlier. +Finally, C implicitly converts arrays to pointers when passing them as +function arguments. This means that a copy is made of the pointer to the +addresee().a array, and that pointer copy is passed to printf(). +But the array data itself is not copied, and may no longer exist when printf() +is called. +Consequently when printf() tries to dereference the pointer passed as +its 2nd argument, it is likely to find garbage. + +/ diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cfg.i frama-c-20111001+nitrogen+dfsg/tests/misc/cfg.i --- frama-c-20110201+carbon+dfsg/tests/misc/cfg.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cfg.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,25 @@ +/ run.config + DONTRUN: cannot find entry point: main +/ + +struct bar { + int x; +}; +struct foo { + struct bar b; + int y; +}; + +int rand(void); + +void f(void) { + int t = rand(); + struct foo f = { + .b = { + .x = (t?2:3), + }, + .y = 42 + }; + return; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/char_ampamp.c frama-c-20111001+nitrogen+dfsg/tests/misc/char_ampamp.c --- frama-c-20110201+carbon+dfsg/tests/misc/char_ampamp.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/char_ampamp.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,17 @@ +/ run.config + OPT: -check + / +char c=1; +int y; + +void g(int y, int x) +{ + Frama_C_show_each_x(x); +} + +main() +{ + y = 42 && c; + g(c, 42 && c); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cmp_ptr.i frama-c-20111001+nitrogen+dfsg/tests/misc/cmp_ptr.i --- frama-c-20110201+carbon+dfsg/tests/misc/cmp_ptr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cmp_ptr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,36 @@ +/ run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -undefined-pointer-comparison-propagate-all +/ + +int p,T[10]={0,1,2,3,4,5,6,7,8,9}; +char C[10]={0,1,2,3,4,5,6,7,8,9}; +char q; +int f(void) { / make a top integer / + int i = 0; + while (&i+(int)&i) { + i++;} + return i; +}; + +int g(void); + +int x,y,z,t,r; +float ff; +int main (int u) { + + p = &T[1] + f(); + q = &C[1] + f(); + + if (p >= &(T[5])) {p=88;q=77;} + x = !(&y+2); + (int)&ff = &y + 2; + y = !ff; + + + z = (u?&f:&g) == 0; + t = (1 + (int)(u?&f:&g)) == 0; + + r = (T-1) == 0; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cond2.i frama-c-20111001+nitrogen+dfsg/tests/misc/cond2.i --- frama-c-20110201+carbon+dfsg/tests/misc/cond2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cond2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,71 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -out-external -input -main zero_ou_un_0 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -out-external -input -main un_1 -journal-disable + +/ + +volatile int Gx; +volatile int Gy; +int px,py,x,y; +int T[100]={0}; + int r = 0; + int s = 0; + int t = 0; + int u = 0; + +void zero_ou_un_0 (void) { + int i ; + + x = Gx ? 0 : 2 ; ; + if (x != 0) + r = 1; + + x = 1; + y = 0; + for (i = 0 ; i < Gx ; i++) x += 2; + for (i = 0 ; i < Gy ; i++) y += 5; + if (x != y) + s = 1; + + x = Gx ? 0 : 2 ; ; + y = Gy ? 1 : 2 ; ; + if (x != y) + t = 1; + + x = Gx ? 0 : 2 ; ; + if (x != 1) + u = 1; + +} + +int un_1 (void) { + int r = 0; + int i ; + x = Gx ? 0 : 2 ; ; + y = Gy ? 1 : 3 ; ; + if (x != y) + r = 1; + + x = 1; + y = 0; + for (i = 0 ; i < Gx ; i++) x += 2; + for (i = 0 ; i < Gy ; i++) y += 2; + if (x != y) + s = 1; + + x = Gx ? 0 : 2; + y = Gy ? 1 : 3; + for (i = 0 ; i < Gx ; i++) x += 4; + for (i = 0 ; i < Gy ; i++) y += 4; + if (x != y) + t = 1; + + px = Gx ? &(T[0]) : &(T[0]); + py = Gy ? &(T[1]) : &(T[1]); + for (i = 0 ; i < Gx ; i++) {px += 4; px=1; } + for (i = 0 ; i < Gy ; i++) {py += 4; py=2; } + if (px != py) + u = 1; + return u; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cond3.i frama-c-20111001+nitrogen+dfsg/tests/misc/cond3.i --- frama-c-20110201+carbon+dfsg/tests/misc/cond3.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cond3.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,88 @@ +int Gx,r,x; +int main(void) { + r = -1; + x = Gx ? 0 : 1 ; + if (x <= 0) {} + else goto fin; + r = x; + fin: + return r; +} + +int main1(void) { + r = -1; + x = Gx ? 0 : 1 ; + if (x <= 0) {goto fin;} + else r=x; + r = x; + fin: + return r; +} + + +int main2(void) { + r = -1; + x = Gx ? 0 : 1 ; + Gx = -2; + if (x <= 0) {Gx = x;} + else goto fin; + r = x; + fin: + return r; +} + + +int main3(void) { + r = -1; + x = Gx ? 0 : 1 ; + Gx = -2; + if (x <= 0) {goto fin;} + r = x; + fin: + return r; +} + + +int main4(void) { + r = -1; + x = Gx ? 0 : 1 ; + Gx = -2; + if (x <= 0) {Gx=5;} + r = x; + fin: + return r; +} + +int main5(void) { + r = -1; + x = Gx ? 0 : 1 ; + if (x <= 0) {} + else {Gx=5;} + r = x; + fin: + return r; +} + +int main6(void) { + r = -1; + x = Gx ? 0 : 1 ; + if (x <= 0) {Gx=5;} + else r=x; + r = x; + fin: + return r; +} + + +int main7(void) { + r = -1; + x = Gx ? 0 : 1 ; + Gx = -2; + if (x <= 0) {} + else {} + r = x; + fin: + return r; +} + + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/cond.i frama-c-20111001+nitrogen+dfsg/tests/misc/cond.i --- frama-c-20110201+carbon+dfsg/tests/misc/cond.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/cond.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,50 @@ +int G; +int x,y; + +int i_auSetEepromProgActive() { + return G?0:(-51); +} + +int i,t[]={ 1, 2, 3, 4, 5, 6, 7, 8 },(p)[8],z, R; + +int main(int argc, charargv) +{ + int r; + int inRet = (0); + char c = argv; + short s = argc; + if(c < 0) + x = c; + if(s >= -10) + y = s; + r = i_auSetEepromProgActive() ; + if (r != (0)) + { + inRet = (-51); + + } + + p = t; + i = argc>=1?argc<=3?argc:1:1; + if ((p)[i]==3) z = i; + + i = argc>=1?argc<=7?argc:1:1; + if (t[i]==4) R = i; + + unsigned u = unknf(); + if (u>=8) u = 8; + if (u!=3) + Frama_C_show_each_2(u); + Frama_C_show_each_3(u); + + unsigned v = 2 u; + if (v!=3) + Frama_C_show_each_4(v); + Frama_C_show_each_5(v); + if (v!=10) + Frama_C_show_each_6(v); + Frama_C_show_each_7(v); + + return inRet; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/conditional_initializer.i frama-c-20111001+nitrogen+dfsg/tests/misc/conditional_initializer.i --- frama-c-20110201+carbon+dfsg/tests/misc/conditional_initializer.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/conditional_initializer.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,2 @@ +int T[1] = {0?(char)1:2}; +void main () {} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/const2.i frama-c-20111001+nitrogen+dfsg/tests/misc/const2.i --- frama-c-20110201+carbon+dfsg/tests/misc/const2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/const2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,7 @@ + +struct S {unsigned char a; int b;}; +const struct S T[2] = {{.a=1,.b=2},{.a=3,.b=4}}; + +unsigned short int main () { + return (T[0].b); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/constarraylibentry.i frama-c-20111001+nitrogen+dfsg/tests/misc/constarraylibentry.i --- frama-c-20110201+carbon+dfsg/tests/misc/constarraylibentry.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/constarraylibentry.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/* run.config + OPT: -memory-footprint 1 -val -lib-entry +/ + +const int t[] = { 1, 2, 3, 4, 5 } ; + +const int t2[3][3] = { 1, 2, 3, 4, 5, 6, 7, 8, 9 } ; + +typedef const int tt3[3]; + +tt3 t3[3] = { 10, 20, 30, 40, 50, 60, 70, 80, 90 } ; + +main() +{ + Frama_C_dump_each(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/const.i frama-c-20111001+nitrogen+dfsg/tests/misc/const.i --- frama-c-20110201+carbon+dfsg/tests/misc/const.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/const.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,57 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main semantique_const_1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main semantique_const_2 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main semantique_const_1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main semantique_const_2 -journal-disable +*/ +extern const int G; +extern int H; +extern int F; +extern const int I=2; + +int G; +int H; + +int X; + +int main () { + H++; + I++; + return G+F; +} + +/** Comportement des analyses au sujet des variables "const" et "non const" : + * + * Les valeurs des variables "const" peuvent �voluer au cours de l'ex�cution + * du code, comme pour toutes autres variables. + * + * Lors d'une analyse de type -lib-entry -main, les variables "const" ont pour + * valeurs initiales, la valeur correspondant � leur expression d'initialisation. + * + * Les valeurs initiales des autres variables sont d'une valeur indertermin�e, mais + * d�pendant de leur type. + / +int cste const = 10 ; +int var = 3 ; + +int input_value_of_cste, output_value_of_cste ; + +void semantique_const_1 (void) { + input_value_of_cste = cste ; + + cste = var ; + + output_value_of_cste = cste ; + +} + +void semantique_const_2 (void) { + const int cste = 10 ; + input_value_of_cste = cste ; + + cste = var ; + + output_value_of_cste = cste ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/const_syntax.i frama-c-20111001+nitrogen+dfsg/tests/misc/const_syntax.i --- frama-c-20110201+carbon+dfsg/tests/misc/const_syntax.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/const_syntax.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,5 @@ +const unsigned char INSTRU_N_00_01_001_CRC___1525983317999999999994352352523523993424999 = 0; +void main () { +const unsigned char INSTRU_N_00_01_001_CRC___1525983317999999999994352352523523993424999 = 0; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/context_free.i frama-c-20111001+nitrogen+dfsg/tests/misc/context_free.i --- frama-c-20110201+carbon+dfsg/tests/misc/context_free.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/context_free.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,53 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -lib-entry -main f -absolute-valid-range 0x200-0x199 -journal-disable +/ + + +int a,b,c; + +int star_p, star_w___500; + +struct str { int s1; int s2; int sp ; int (sg)(char ) ; } s; + +struct str t; + +struct strstr { struct str ss1; int ss2; } tt; + +int u[12]; +int v[12][3]; +int *(w[12]); + +struct str ts[10]; + +union uni { int u1 ; struct str u2 ; } uu ; + +struct str_arith { int s1; int s2; float s3; } ; + +union uni_arith { int u1 ; struct str_arith u2 ; float u3 ; } uuu ; + +const int c_int = 34; + + +int f(int x, float y, int **p, int (g)(char ), void *vv, void **vvv, int ta[5]) +{ + if (x >= 0) a = x; + b = s.s1 ; + t.s2 = 3; + tt.ss2 = c; + p = p; + p = p; + u[1]=2; + v[0][0]=5; + w[4]=&a; + (ts[3]).s1 = (ts[3]).s1 ; + vv = vv; + vvv = vvv; + c_int = c_int; + uu.u1 = uu.u1; + uuu.u1 = uuu.u1; + ta[1]=3; + ta=ta; + return g("toto"); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/context_free_simple.i frama-c-20111001+nitrogen+dfsg/tests/misc/context_free_simple.i --- frama-c-20110201+carbon+dfsg/tests/misc/context_free_simple.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/context_free_simple.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ + +int z=1; + +int f(int x,int y) +{ + z = x+y; + return y+1; +} + +void main(void) +{ + f(2,3); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/control.i frama-c-20111001+nitrogen+dfsg/tests/misc/control.i --- frama-c-20110201+carbon+dfsg/tests/misc/control.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/control.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable +/ + +int x,y,c,d; + + +void f() { + int i; + for(i=0; i<4 ; i++) { + if (c) { if (d) {y++;} else {x++;}} + else {}; + x=x+1; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/copy_logic.i frama-c-20111001+nitrogen+dfsg/tests/misc/copy_logic.i --- frama-c-20110201+carbon+dfsg/tests/misc/copy_logic.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/copy_logic.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/ run.config + OPT: -check -copy -val -print -journal-disable + / + +/@ predicate p(int x); / +/@ predicate q(int x) = x == 42; / +/@ logic int f (int y); / +/@ logic integer g (int x) = x + 42; / + +int main (int x) { + int y = 42; + /@ assert q(y) && p(x); / + y+=x; + /@ assert g(x) == f(y); / + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/copy_paste_hidden_by_dummy_cast.i frama-c-20111001+nitrogen+dfsg/tests/misc/copy_paste_hidden_by_dummy_cast.i --- frama-c-20110201+carbon+dfsg/tests/misc/copy_paste_hidden_by_dummy_cast.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/copy_paste_hidden_by_dummy_cast.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,20 @@ +typedef unsigned short T_WORD16; +typedef unsigned int T_WORD32; +typedef short T_INT16; +typedef float T_FLOAT; + +struct S { + T_INT16 a ; + T_WORD32 b ; +}; +typedef struct S T_ERREUR_ANO; + +T_ERREUR_ANO const A4O1_Ci_sNO_ERREUR_ANO = {0, 0}; + +void main () { + struct S Rl_sErreurAno ; + Rl_sErreurAno = A4O1_Ci_sNO_ERREUR_ANO; + +} + + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/copy_paste.i frama-c-20111001+nitrogen+dfsg/tests/misc/copy_paste.i --- frama-c-20110201+carbon+dfsg/tests/misc/copy_paste.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/copy_paste.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +int t[12],G; + +void main(int c) { + volatile int l=0; + int i=c?3:4; + int j=c?(-3):4; + t[i] = i; + t[j] = j; + l = (int)l; + G=l; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/copy_stdin.i frama-c-20111001+nitrogen+dfsg/tests/misc/copy_stdin.i --- frama-c-20110201+carbon+dfsg/tests/misc/copy_stdin.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/copy_stdin.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,6 @@ +int leaf(void); +void main () { + int * stdin, toto; + stdin = leaf(); + toto = stdin; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/copy_visitor.i frama-c-20111001+nitrogen+dfsg/tests/misc/copy_visitor.i --- frama-c-20110201+carbon+dfsg/tests/misc/copy_visitor.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/copy_visitor.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,25 @@ +/ run.config + OPT: -check -copy -val -print -journal-disable + / +struct S { + int a; + int b; +}; +struct S s = {.a = 1, .b=2}; + +/@ + requires \valid(s); + assigns s->a; +/ +int f(struct S s){ + s->a=2; + return s->b; +} + +/@ assigns s.a; / +int main () { + s.a = 2; + /@ assert s.a == 2; / + f(&s); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/dead_code2.i frama-c-20111001+nitrogen+dfsg/tests/misc/dead_code2.i --- frama-c-20110201+carbon+dfsg/tests/misc/dead_code2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/dead_code2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +int G; +void main(void) { + int i,j,k,l; + + i=10; + G=0; + L: if (i=1) goto OUT; + i = i - 1 - G; + j+=i; + goto L; + OUT: + l=17; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/dead_code.i frama-c-20111001+nitrogen+dfsg/tests/misc/dead_code.i --- frama-c-20110201+carbon+dfsg/tests/misc/dead_code.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/dead_code.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +void main(int in) { + int i,j=6,k,l; + + i=10; + //@ impact pragma stmt; + i=1; + L: if (i) {l= 17 ; goto OUT;} +// i--; +// j+=i; +// goto L; +// while (1); + + OUT: j = l; + l=17; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/dead_inout.i frama-c-20111001+nitrogen+dfsg/tests/misc/dead_inout.i --- frama-c-20110201+carbon+dfsg/tests/misc/dead_inout.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/dead_inout.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +/* run.config + OPT: -out -input + / + +int a, b; + +void f() { + a = b; +} + +void g () { + int x = 0; + if (x) f (); +} + +void main(){ + f (); + g (); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/deep_conditionals.i frama-c-20111001+nitrogen+dfsg/tests/misc/deep_conditionals.i --- frama-c-20110201+carbon+dfsg/tests/misc/deep_conditionals.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/deep_conditionals.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,3 @@ +void main(void) { char X,Y ; + Y = ((X=66, ((0 == 1) || (X=22,X=33,2==3)) && (4==5)))? (((X=66, ((0 == 1) || (X=22,X=33,2==3)) && (4==5))) ? 99:77):77 ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/degeneration2.i frama-c-20111001+nitrogen+dfsg/tests/misc/degeneration2.i --- frama-c-20110201+carbon+dfsg/tests/misc/degeneration2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/degeneration2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +void main (int c,int d) { +void A,B,C,D, E; + + if (c) {A = (void)&B; + B= (void)&C; + C= (void)&D; + D= (void)&E; + }; + A = (void)(-(int)A); + + while (c) { + A = (void)((int)A); + } + + int offset_uninit; + char T[10][10]; + int x = (d<=10)?((d>=0)?d:0):0; + + int vv = T[x][offset_uninit]; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/degeneration.i frama-c-20111001+nitrogen+dfsg/tests/misc/degeneration.i --- frama-c-20110201+carbon+dfsg/tests/misc/degeneration.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/degeneration.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ + + +void main(char c) { + int **p; + int * pp = *p; + int ppp = **p; + int pppp = ppp; + int qq = (c?&ppp:&pppp); + int qqq = qq; + + int q = p+1; + p=1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/deps_addr.i frama-c-20111001+nitrogen+dfsg/tests/misc/deps_addr.i --- frama-c-20110201+carbon+dfsg/tests/misc/deps_addr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/deps_addr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,7 @@ +int t; +int a; +int tt[5][5]; +int main () { + + return (&(t[(int)&a])); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/deps.i frama-c-20111001+nitrogen+dfsg/tests/misc/deps.i --- frama-c-20110201+carbon+dfsg/tests/misc/deps.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/deps.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,53 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main fonc1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main fonc2 -journal-disable +/ +int f (int a, int b,int c){ + int w,d; + + if (c) b = 0; + return w; +} + +int fonc1 (int a, int b){ + int w; + struct t1 { int x; int y;} v1; + v1.x = a+b; + w = v1.x; + if (a) { + struct t1 { int x; int y;} v2; + struct t2 { int x; int y;} v3; + v2.x = a; + v3.x = b; + w = w + v2.x + v3.x; + } + return w; +} + +int fonc2 (int a, int b){ + int w; + struct t1 { int x; int y;} v1; + v1.x = a+b; + w = v1.x; + return w; +} + +struct Tstr { int a; int b; }; + +int h (struct Tstr ps) { + return ps->a; +} +int ptr (intpt) { + return pt; +} +int i (int x, int y) { + struct Tstr s;// = {x, y}; + int g; + g=0; + return ((&g)); + return ptr(&g); + s.a = 0; + return h(&s); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/deps_local.i frama-c-20111001+nitrogen+dfsg/tests/misc/deps_local.i --- frama-c-20110201+carbon+dfsg/tests/misc/deps_local.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/deps_local.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,23 @@ +int G,H; + +int h(int argh) { +// G = argh; + argh = H; +} + +int g() { + int ga; + h(&ga); + return 0; +} + +int f() { + int fa; + h(&fa); + return 0; +} + +int main() { + f(); + g(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/deps_mixed.i frama-c-20111001+nitrogen+dfsg/tests/misc/deps_mixed.i --- frama-c-20110201+carbon+dfsg/tests/misc/deps_mixed.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/deps_mixed.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +int p,q; +int a,b; +int r=2; +int main (int c, int d) { + p=c?&a:(int)3; + q=d?&b:(int)2; + r = ((p+ (int)q)); + return ((int)(p+ (int)q)); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/deref.i frama-c-20111001+nitrogen+dfsg/tests/misc/deref.i --- frama-c-20110201+carbon+dfsg/tests/misc/deref.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/deref.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -deref -journal-disable +/ +int a,b,c,d,e,p, t[10]; + + +int main (void) +{ + int i = 0; + p = &a; + return p + b + (&c) + (&d)[i] + t[i]; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/div.i frama-c-20111001+nitrogen+dfsg/tests/misc/div.i --- frama-c-20110201+carbon+dfsg/tests/misc/div.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/div.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,38 @@ +/* run.config + STDOPT: +"-remove-redundant-alarms" + / +int X,Y,Z1,Z2,T,U1,U2,V,W1,W2; +int a,b,d1,d2,d0,e; +int t[5]={1,2,3}; + +int p; + +void main (void) +{ + int i; + volatile int c=0; + while (c+1) + { + if (c) X++; + if (c+2) X--; + } + Y = -5; + if ((X>=Y) && (X<=12) ) + Y = X; + Y = 27 * Y + 9; + Z1 = Y / 3; + Z2 = Y / 5; + V = Y + 1; + W1 = V / 3; + W2 = V / 5; + T = Y + 160; + U1 = T / 3; + U2 = T / 5; + p = &(t[3]); + a = 40000/Z2; + b = ((int)&Z2)/Z2; + d2 = 100 / (int)(&X + 2); + d1 = 100 / (int)(&X + 1); + d0 = 100 / (int)(&X); + e = - (int) &X; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/div_strange.i frama-c-20111001+nitrogen+dfsg/tests/misc/div_strange.i --- frama-c-20110201+carbon+dfsg/tests/misc/div_strange.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/div_strange.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +int main() { + + int x = -1; + + x /= sizeof(unsigned int); + + CEA_F(x); + +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/duff.i frama-c-20111001+nitrogen+dfsg/tests/misc/duff.i --- frama-c-20110201+carbon+dfsg/tests/misc/duff.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/duff.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,24 @@ +/* run.config + DONTRUN: +/ + +int Ato[100]; +int Afrom[100]; + +void main(int count) { + intto = &Ato; + intfrom = &Afrom; +//@ assert count > 0 ; +switch (count % 8) / count > 0 assumed / + { + case 0: do { to = from++; + case 7: to = from++; + case 6: to = from++; + case 5: to = from++; + case 4: to = from++; + case 3: to = from++; + case 2: to = from++; + case 1: to = from++; + } while ((count -= 8) > 0); + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/dur.i frama-c-20111001+nitrogen+dfsg/tests/misc/dur.i --- frama-c-20110201+carbon+dfsg/tests/misc/dur.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/dur.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,182 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -float-normal -val -deps -out -input -main F2 -journal-disable +/ + +struct T1 { + float M1 ; + unsigned short M2 ; + unsigned short M3 ; +}; +typedef struct T1 T2; +struct T3 { + unsigned short M4 ; + unsigned short M5 ; +}; +typedef struct T3 T4; +struct T5 { + float M6 ; + float M7 ; + float M8 ; + float M9 ; + float M10 ; + float M11 ; + float M12 ; + float M13 ; + float M14 ; + float M15 ; + float M16 ; + float M17 ; + float M18 ; + float M19 ; + float M20 ; + float M21 ; + float M22 ; + float M23 ; + float M24 ; + float M25 ; + float M26[(unsigned short)26] ; + float M27[(unsigned short)13] ; + float M28[(unsigned short)3] ; + float M29 ; + float M30 ; + float M31 ; + float M32 ; + float M33 ; + float M34 ; + float M35 ; + float M36 ; + float M37 ; + float M38 ; + float M39 ; + float M40 ; + float M41 ; + float M42 ; + float M43 ; + float M44 ; + float M45 ; + float M46 ; + float M47 ; + float M48 ; + float M49 ; + float M50 ; + float M51 ; + float M52 ; + float M53 ; + float M54 ; + float M55 ; + float M56 ; + float M57 ; + float M58 ; + float M59 ; + float M60 ; + float M61 ; + float M62 ; + float M63 ; + float M64[27] ; + float M65[27] ; + float M66[(unsigned short)48] ; + float M67[(unsigned short)48] ; + float M68[(unsigned short)48] ; + float M69[(unsigned short)48] ; + float M70[48] ; + float M71[48] ; + float M72[48] ; + float M73[48] ; + float M74[(unsigned short)10] ; +}; +typedef struct T5 T6; +struct T7 { + unsigned short M75 ; + T2 M76[(unsigned short)53] ; + T2 M77 ; + T2 M78 ; + T2 M79 ; + T2 M80 ; + T2 M81 ; + T2 M82 ; + T2 M83 ; + T2 M84 ; + T2 M85 ; + T2 M86 ; + T2 M87 ; + T2 M88 ; + T2 M89 ; + T4 M90[(unsigned short)4] ; + T4 M91 ; + T2 M92[(unsigned short)6] ; + T4 M93[(unsigned short)5] ; +}; +typedef struct T7 T8; +struct T9 { + unsigned short M94[(unsigned short)1][16] ; + unsigned short M95[(unsigned short)1] ; + unsigned short M96[(unsigned short)1] ; + unsigned short M97[(unsigned short)1] ; + unsigned short M98 ; +}; +typedef struct T9 T10; +int G1 ; +int G2 ; +extern unsigned char G3 ; +extern T6 const G4 ; +extern T8 G5 ; +extern T10 G6 ; +extern unsigned char G7[(unsigned short)161] ; +void F1(T2 V1 , T2 V2 , unsigned short const V3 , + unsigned short const V4 ) +{ + + {if ((int )V1->M2 != 0) + {if ((int )V1->M2 == 2) {G7[V3] = (unsigned char)1;} + else {G7[V3] = (unsigned char)0;} + + V1->M2 = (unsigned short)1; + if ((int )V2->M2 == 0) + {G7[V4] = (unsigned char)0; + if (V2->M1 <= G4.M16) {G7[V3] = (unsigned char)1; + if (V2->M1 <= G4.M17) {G7[V4] = (unsigned char)1; + V2->M2 = (unsigned short)1;} + } + } + else {G7[V4] = (unsigned char)1; + V2->M2 = (unsigned short)1;} + } + else {G7[V3] = (unsigned char)0; + V2->M2 = (unsigned short )((int )V2->M2 != 0); + G7[V4] = (unsigned char )V2->M2;} + + return;} + +} +void F2(unsigned short V8 ) +{ unsigned short V5 ; + unsigned short V6 ; + unsigned short V7 ; + + {G5.M75 = (unsigned short )G3; + if ((int )V8 == 0) {if ((((int )G6.M97[0] & 1) == 1) == 1) + {G5.M91.M4 = (unsigned short)0; + G5.M91.M5 = (unsigned short)1;} + else {G5.M91.M4 = (unsigned short )(((int )G6.M96[0] & 1) == 1); + G5.M91.M5 = (unsigned short)0;} + + V6 = (unsigned short)0; + V7 = (unsigned short)2; + V5 = (unsigned short)0; + while ((int )V5 < 4) {if (G2) + {G5.M90[V5].M4 = (unsigned short)0; + G5.M90[V5].M5 = (unsigned short)1;} + else {G5.M90[V5].M4 = (unsigned short )G1; + if ((int )G5.M90[V5].M4 == 1) {V6 = (unsigned short )( + (int )V6 + 1);} + + G5.M90[V5].M5 = (unsigned short)0;} + + V7 = (unsigned short )(2 (int )V7); + V5 = (unsigned short )((int )V5 + 1);} + } + + return;} + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/endian.i frama-c-20111001+nitrogen+dfsg/tests/misc/endian.i --- frama-c-20110201+carbon+dfsg/tests/misc/endian.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/endian.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,40 @@ + +struct S {unsigned char a; unsigned char b; char c; unsigned char d;} v1; + +union U {unsigned int full; struct S part;} UU; +unsigned char b0,b1,b2,b3; +unsigned int f; + + +union U0 { + unsigned short f0 ; + int f1 ; + int f2 : 5 ; + unsigned char const f3 ; +}; + +unsigned short G0 ; +int G1 ; +int G2; +unsigned char G3 ; +union U0 G={(unsigned short)65532U}; + + + +void main (void) { + union U data0; + data0.full = 0xFF030201; + b0 = data0.part.a + 1 - 1; + b1 = data0.part.b + 1 - 1; + b2 = data0.part.c + 1 - 1; + b3 = data0.part.d + 1 - 1; + data0.part.a = 0; + f = data0.full + 1 -1; + + G0=G.f0; + G1=G.f1; + G2=G.f2; + G3=G.f3; + + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/ensures.i frama-c-20111001+nitrogen+dfsg/tests/misc/ensures.i --- frama-c-20110201+carbon+dfsg/tests/misc/ensures.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/ensures.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +/* run.config_no_native_dynlink + CMD: bin/toplevel.byte + OPT: -load-script tests/misc/ensures.ml +/ +/ run.config + OPT: -load-script tests/misc/ensures.ml +/ +//@ ensures p==1; +void main(int * p){ p = 0; } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/ensures.ml frama-c-20111001+nitrogen+dfsg/tests/misc/ensures.ml --- frama-c-20110201+carbon+dfsg/tests/misc/ensures.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/ensures.ml 2011-10-10 08:39:03.000000000 +0000 @@ -1,7 +1,7 @@ open Cil_types let run () = - Parameters.Dynamic.Bool.set "-context-valid-pointers" true; + Dynamic.Parameter.Bool.set "-context-valid-pointers" true; !Db.Value.compute (); Globals.Functions.iter (fun kf -> @@ -10,21 +10,14 @@ let ip = Property.ip_of_spec kf Kglobal spec in List.iter (fun ip -> - let bname = - match Property.get_behavior ip with - Some b -> b.b_name - | None -> "Ook" + let bname = match Property.get_behavior ip with + | None -> "Ook" + | Some b -> b.b_name in - let function_name = - kf_name ^ ": behavior " ^ bname - in - let statuses = Properties_status.get_all ip in - List.iter - (fun status -> - Kernel.result "%s %a" - function_name Cil.d_annotation_status status) - statuses) + let function_name = kf_name ^ ": behavior " ^ bname in + let status = Property_status.get ip in + Kernel.result "@[%s@ @[%a@]@]" + function_name Property_status.pretty status) ip) -;; -Db.Main.extend run +let () = Db.Main.extend run diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/enum2.c frama-c-20111001+nitrogen+dfsg/tests/misc/enum2.c --- frama-c-20110201+carbon+dfsg/tests/misc/enum2.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/enum2.c 2011-10-10 08:39:03.000000000 +0000 @@ -1,6 +1,6 @@ / run.config GCC: - OPT: -cpp-command "gcc -C -E -I. %1 > %2" -memory-footprint 1 -val -deps -out -input -main sizeof_enum1 -journal-disable + OPT: -check -cpp-command "gcc -C -E -I. %1 -o %2" -memory-footprint 1 -val -deps -out -input -journal-disable / / This test of enums doubles with a test of the % syntax in -cpp-command / @@ -12,8 +12,11 @@ E1_SGN1 = BIT_DE_SIGNE_1, E1_SGN0 = BIT_DE_SIGNE_0 } E1 ; + +E1 f(E1 x) { return x; } + unsigned char enum1_sgn1_positif (void) { - unsigned char res = E1_SGN1 > 0; + unsigned char res = (f((E1)E1_SGN1)) > 0; printf ("enum1_sgn1_positif = %d\n", res); return res; / WARN : ppc->0 ; gcc->1 / } @@ -22,8 +25,11 @@ printf ("enum1_sgn1_inf_sgn0 = %d\n", res); return res; / WARN : ppc->1 ; gcc->0 / } -int sizeof_enum1 (void) { +unsigned char must_be_one, must_be_zero; +int main (void) { int res = sizeof (E1); + must_be_zero = enum1_sgn1_inf_sgn0(); + must_be_one = enum1_sgn1_positif(); printf ("sizeof_enum1 = %d\n", res); - return res; / WARN : ppc->4 ; gcc->8 / + return res; } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/enum.i frama-c-20111001+nitrogen+dfsg/tests/misc/enum.i --- frama-c-20110201+carbon+dfsg/tests/misc/enum.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/enum.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable +/ +typedef enum counter {ZERO,ONE,TWO,LAST=TWO}; + +int t [LAST + 1] = { 1 }; +int u [TWO + 1] = { 2 }; + +void f(void) +{ + int i[3]={0}; + t[2] = 42; + u[TWO] = 36; + enum counter j=0; + for(j=0;j<2;j++) + i[j] = 1; + + enum counter k = ZERO; + //@ assert k == ZERO; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/extern.i frama-c-20111001+nitrogen+dfsg/tests/misc/extern.i --- frama-c-20110201+carbon+dfsg/tests/misc/extern.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/extern.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,18 @@ +extern int T1; +extern const int T2; + +extern int T3[]; +extern const int T4[]; + +extern int T5[3]; +extern const int T6[3]; + +void main () { +// T1++; +// T2++; + T1= T3[3]; + T2= T4[3]; + T1= T5[1]; + T2= T6[1]; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/f1.i frama-c-20111001+nitrogen+dfsg/tests/misc/f1.i --- frama-c-20110201+carbon+dfsg/tests/misc/f1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/f1.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,7 @@ + +extern int f(int x); + +void main() { + f(5); + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/f2.i frama-c-20111001+nitrogen+dfsg/tests/misc/f2.i --- frama-c-20110201+carbon+dfsg/tests/misc/f2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/f2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable +/ +int f(int x) { +/ Here we are / +/@ loop pragma UNROLL_LOOP 10; / + while(1) { return 0 ;} + return 2; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/false.i frama-c-20111001+nitrogen+dfsg/tests/misc/false.i --- frama-c-20110201+carbon+dfsg/tests/misc/false.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/false.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/@ requires i == 1; + requires i == 1; + requires i == 1; / +void f (int i); + +/@ ensures \result == 1; + ensures \result == 1; / +int g (int i) { + return i; +} + +void main (int bla, int bli) { + int i=0; + if (bla) f(i); + if (bli) g(i); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/find_ivaltop.i frama-c-20111001+nitrogen+dfsg/tests/misc/find_ivaltop.i --- frama-c-20110201+carbon+dfsg/tests/misc/find_ivaltop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/find_ivaltop.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +int t[20]={1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0}; + +int main(void) +{ + int i,j=0,X=0; + for (i=0;i<8;i++) + j=i; + if (j<=7) X=j; + X=t[X]; + return X; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/folding.i frama-c-20111001+nitrogen+dfsg/tests/misc/folding.i --- frama-c-20110201+carbon+dfsg/tests/misc/folding.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/folding.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,31 @@ +int f(int x) {return x;}; + +int g() { + int (pfct)(int) = &f; + int un = 1; + int p =&un; + int deux = 1+un; + int trois ; + p = &deux; + trois = p+p+un; + return (pfct)(trois); +} + +int foo(int x, int y) { + volatile int unknown=0; + if (unknown) + return y+2; + return x+3; + } + +int main () { + int a,b,c; + g(); + a = foo(5,7) + foo(6,777); + b = 4; + c = b * b +a; + if (b > c) + return b-c; + else + return b+c; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/for_loops.i frama-c-20111001+nitrogen+dfsg/tests/misc/for_loops.i --- frama-c-20110201+carbon+dfsg/tests/misc/for_loops.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/for_loops.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,40 @@ +int x; + +int f(); + + +void main_2 () { + int i,j; + int nSelectors = Frama_C_interval(0,100); + int w=0,v = 0; + + for (j = 0; j < nSelectors; j++) { if (Frama_C_interval(0,1)) w += 1; + CEA_F(w);} + // w widens to top_int + +} + +void main () { + int i,j; + int nSelectors = Frama_C_interval(0,0x7FFFFFFF); + int w=0,v = 0; + + for (j = 0; j <= nSelectors; j++) + { v = j ; + while (v>0) v--; + CEA_F(j);} + +} + +void g () { + int j; + int T[1000]; + int nSelectors = Frama_C_interval(0,1000); + int w=0; + CEA_DUMP(); + for (j = 0; j < nSelectors; j++) T[j] = 1; + CEA_DUMP(); + for (j = 0; j < nSelectors; j++) w += T[j]; +//@ assert nSelectors == w ; + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/FP5.i frama-c-20111001+nitrogen+dfsg/tests/misc/FP5.i --- frama-c-20110201+carbon+dfsg/tests/misc/FP5.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/FP5.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,31 @@ +/@ requires \valid(b); + @ requires \valid(c); + @ requires \valid(&a); + @ assigns b; + @ assigns c; + @/ +void main(int a, int b, int c) +{ + int i=0; + + if (a==1) + { + b=1; + c=1; + } + else if (a==-1) + { + b=-1; + c=-1; + } + else + { + while (i<a) + { + b=0; + i++; + } + c=0; + } + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/fptr.i frama-c-20111001+nitrogen+dfsg/tests/misc/fptr.i --- frama-c-20110201+carbon+dfsg/tests/misc/fptr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/fptr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,72 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -journal-disable + OPT: -memory-footprint 1 -val -deps -out -main main_uninit -journal-disable +/ +int R=77; + +int f(int (ptr(int x))) { + R = ptr(1); + return R; +} + +int X=77,XH=0,XHH=0; + +int h (int y) {X = y; XH= y; return X;} ; +int hh (int y) {X = y+y; XHH = y; return X;} ; + +extern int hhh(int y); + +typedef int (* PTR_FCT)(int); +typedef PTR_FCT TYPE[10]; +TYPE GLOBAL; +int G; + +short retshort(void) +{ + return 12; +} + +int retint(void) +{ + return 42; +} + +int TA; + +void main (int c) +{ + int in, pin; + short sh, psh; + + if (c&1) in = retshort(); + if (c&2) sh = retint(); + if (c&4) pin = (((int ()())retshort))(); + if (c&8) psh = (((short ()())retint))(); + + int i=0; + GLOBAL[0] = h; + GLOBAL[1] = hh; + for(i=0;i<3;i++) { + CEA_F(GLOBAL[i]); + G=f(GLOBAL[i]); + } + + PTR_FCT p = (c&16) ? &h : &hh; + if (c&32) TA=(p)(1/(c&64)); +} + +void main_uninit (int c) +{ + int i=0; + volatile int j=0; + GLOBAL[2]=j; + GLOBAL[0] = h; + GLOBAL[1] = hh; + for(i=0;i<3;i++) { + CEA_F(GLOBAL[i]); + G=f(GLOBAL[i]); + } +} + + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from1.i frama-c-20111001+nitrogen+dfsg/tests/misc/from1.i --- frama-c-20110201+carbon+dfsg/tests/misc/from1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from1.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,28 @@ +int G; + +int cx,cy,cz,sx,sy,s; + +struct Tstr { int a; int b; }; + + +void f(void) +{ + cy = cx; +} + +int sf (struct Tstr ps) { + return ps->a; +} + +int main(int x,int y) { + struct Tstr s = {sx, sy}; + + if (x) G=y; + + cx = cz; + f(); + + return sf(&s); +} + + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from_call.i frama-c-20111001+nitrogen+dfsg/tests/misc/from_call.i --- frama-c-20110201+carbon+dfsg/tests/misc/from_call.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from_call.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,97 @@ +/* run.config + OPT: -memory-footprint 1 -calldeps -users -val -journal-disable -input +/ + +int a,b,c,d; +int x,y,z,t; + +int g(int w) +{ + return w + t; +} + +int h(int); + +int f(int p) +{ + static int * previous = &a; + p = previous; + previous = p; + return g(h(x)+p); +} + +int A1,A2,A3,A4,A5,A6,A7,A8; +int R1,R2,R3,S1,S2,S3; +int T0,T1,T2; + +int dispatcher(int c, int y, int z, int x) +{ + return c ? y : z; +} + +int return_A1(void) +{ + return A1; +} + +int return_A2(void) +{ + return A2; +} + +int dispatcher2(int c) +{ + return c ? return_A1() : return_A2(); +} + +int call_dispatcher2_1(void) +{ + return dispatcher2(1); +} + +int call_dispatcher2_0(void) +{ + return dispatcher2(0); +} + +int call_dispatcher2(int r) +{ + return dispatcher2(r); +} + +int tab[5]; + +int access_tab(int ind) +{ + return tab[ind]; +} + +int AA,AR,AS; +int At[2]={&AA}; +int Ar[2]={&AA}; +int Ap=At; + +/@ assigns AR \from Ap[..] ; + assigns AS \from Ar[..] ; + / +void unavailable_f(void); + +void main(int r) +{ + y = f(&b); + z = f(&c) + f(&d); + R1 = dispatcher(1,A1,A2,A3); + R2 = dispatcher(0,A3,A4,A6); + R3 = dispatcher(r,A4,A5,A7); + S1 = call_dispatcher2_1(); + S2 = call_dispatcher2_0(); + S3 = call_dispatcher2(r); + tab[0]=A1; + tab[1]=A2+A3; + tab[2]=A4; + T0 = access_tab(0); + T1 = access_tab(1); + T2 = access_tab(2); + + unavailable_f(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from_global.i frama-c-20111001+nitrogen+dfsg/tests/misc/from_global.i --- frama-c-20110201+carbon+dfsg/tests/misc/from_global.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from_global.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +int A,B,C,D,E; + +int f(int x) +{ + B = A; + C = x; +} + +int main(void) +{ + A = D; + f(E); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from_pb.i frama-c-20111001+nitrogen+dfsg/tests/misc/from_pb.i --- frama-c-20110201+carbon+dfsg/tests/misc/from_pb.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from_pb.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,95 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main main0 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main2 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main3 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main4 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main4bis -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main5 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main5bis -journal-disable +/ + +int k,i,j,x,c,d,T[10]; + +void main0(){ + + if (j) + {if (c) x=i; else x=d;} + else x=k; +} + +void main1(){ + + if (j) + {if (c) T[0]=i; else T[1]=d;} + else x=k; +} + +void main2(){ + if (j) + {if (c) ((int)((char)T+1))[0]=i; else T[1]=d;} + else x=k; +} + + +void main3(){ + int p = ((int)((char)T+1)); + + if (c) { p[0]=i; p[1]=d;} else T[1] = x; + +} + +void main4() +{ + if (c) + { + T[0]=i; + T[2]=j; + } + else + { + T[0]=k; + } + +} + +void main4bis() +{ + if (c) + { + T[0]=k; + } + else + { + T[0]=i; + T[2]=j; + } +} + +void main5() +{ + if (c) + { + T[0]=i; + T[1]=j; + } + else + { + T[0]=k; + } + +} + +void main5bis() +{ + if (c) + { + T[0]=k; + } + else + { + T[0]=i; + T[1]=j; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from_ptr2.i frama-c-20111001+nitrogen+dfsg/tests/misc/from_ptr2.i --- frama-c-20110201+carbon+dfsg/tests/misc/from_ptr2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from_ptr2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +struct Tstr { int a; int b; }; +int f (struct Tstr * ps) { + return ps->a; +} +int main (int x, int y) { + struct Tstr s = {x, y}; + return f(&s); +} +/* +Function main: + \result FROM s.a; +/ diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from_ptr.i frama-c-20111001+nitrogen+dfsg/tests/misc/from_ptr.i --- frama-c-20110201+carbon+dfsg/tests/misc/from_ptr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from_ptr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,31 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main1 -journal-disable +/ +long i,j,x,k,l,m,n,d,a,b; + +int p[10][10][10]={0}; +long q; + +void main(int c) { + i = &p[11]; + i = &p[10]; + + if (c) + // This branch is assumed to be dead since "i" is an invalid pointer. + ((int)i) = a; + + q = c ? &a : &b ; // So, "q" points only on "b". + d = q; // "d" is only from "a" and "c". +} + +void main1(int c) { + i = &p[1]; + i = &p[0]; + + if (c) ((int)i) = a; + + q = c ? &a : &b ; + d = q; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from_res_2.i frama-c-20111001+nitrogen+dfsg/tests/misc/from_res_2.i --- frama-c-20110201+carbon+dfsg/tests/misc/from_res_2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from_res_2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,23 @@ +typedef unsigned char T; +// typedef int T; +int G; +T f (int left, int right ) { + return left + right; +} + +int A, C; + +struct S { int a; int b; int c;} x, y; + +struct S g(void){ + return x; +} + +void main (void) +{ int * p = &G; + p = f (G, 3); + x.a = A; + x.c = C; + y = g(); + } + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/from_termin.i frama-c-20111001+nitrogen+dfsg/tests/misc/from_termin.i --- frama-c-20110201+carbon+dfsg/tests/misc/from_termin.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/from_termin.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +int b,c,d,e; + +void main(int a) +{ + if (a) + b = c; + else + while (1) d = e; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/function_return_serial_casts.i frama-c-20111001+nitrogen+dfsg/tests/misc/function_return_serial_casts.i --- frama-c-20110201+carbon+dfsg/tests/misc/function_return_serial_casts.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/function_return_serial_casts.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +short x = -10; +int y, z, t; + +unsigned short f(void) +{ + return x; +} + +unsigned short g(void) +{ + unsigned short l = (unsigned short)&x; + return l; +} + +main(){ + y = (unsigned short)&x; + z = f(); + t = g(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/fun_ptr.i frama-c-20111001+nitrogen+dfsg/tests/misc/fun_ptr.i --- frama-c-20110201+carbon+dfsg/tests/misc/fun_ptr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/fun_ptr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,43 @@ + + +int f(int x) +{ + return x+1; +} + +int g(int x, int y) +{ + return x+y; +} + +typedef int (fptr1)(int); +typedef int (fptr2)(int, int); +typedef double (fptr3)(int); + +long t[2] = { (long)&f, (long)&g }; + +int R1, R2; +double R3; + +void test1(int nd) +{ + R1 = ((fptr1)(t[nd]))(3); +} + +void test2(int nd) +{ + R2 = ((fptr2)(t[nd]))(3, 4); +} + +void test3(int nd) +{ + R3 = ((fptr3)(t[nd]))(5); +} + +main(int c){ + test1(!(c&1)); + test2(!(c&2)); + if (c&4) test3(!(c&8)); + + return 0; +} \ No newline at end of file diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/g1.i frama-c-20111001+nitrogen+dfsg/tests/misc/g1.i --- frama-c-20110201+carbon+dfsg/tests/misc/g1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/g1.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,2 @@ +extern int G = 1; +void main (){} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/ghost.i frama-c-20111001+nitrogen+dfsg/tests/misc/ghost.i --- frama-c-20110201+carbon+dfsg/tests/misc/ghost.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/ghost.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,29 @@ + +/* Commentaire avant G / / Commentaire avant G2 / +int G; +/ Commentaire apres G avant main / + +/@ ghost int GHOST ; / + +int main () { +/ Commentaire apres main / + int i; +/ Commentaire apres int i / + G = 0; +/@ghost GHOST=G+G ; / +/ Commentaire avant loop / + /@ loop pragma UNROLL_LOOP 0; / + for(i=0; i<=10; i++) + G++; + +// AVANT j + {int / milieu j/ j; + j = / milieu j 2/ 0; } +// APRES j + + return i; +} + +/ ICI avant H / +int H; +/ ICI apr�s H / diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/ghost_lexing.i frama-c-20111001+nitrogen+dfsg/tests/misc/ghost_lexing.i --- frama-c-20110201+carbon+dfsg/tests/misc/ghost_lexing.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/ghost_lexing.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,18 @@ +/ run.config + OPT: -journal-disable -print +/ + +int G = 0; + +const char foo = "foo"; + +void test(const char /name/); + +void test2(int x) { + /@ ghost + int y = 0; + if (x>0) { y = x * x; }; + / + G = x x; + test(foo); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/global_bug.i frama-c-20111001+nitrogen+dfsg/tests/misc/global_bug.i --- frama-c-20110201+carbon+dfsg/tests/misc/global_bug.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/global_bug.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,8 @@ +int i = 1; +int G = 99<<63; +int j = 2; + +int main () { + G ++; + return (i == j); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/goto.i frama-c-20111001+nitrogen+dfsg/tests/misc/goto.i --- frama-c-20110201+carbon+dfsg/tests/misc/goto.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/goto.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +int stop () { + L: goto L; + +} + +int main() { + volatile int c=0; + c = c?1:0; + + if (c) stop (); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/if2.i frama-c-20111001+nitrogen+dfsg/tests/misc/if2.i --- frama-c-20110201+carbon+dfsg/tests/misc/if2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/if2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,25 @@ +typedef enum { + AU_NO_MODE = 0, + AU_ANLAUF = (0x0001), + AU_BETRIEB = (0x0002), + AU_PARAMETRIEREN = (0x0004), + AU_FUNKTIONSPRFNG = (0x0008), + AU_DIAGNOSE = (0x0010), + AU_RESET = (0x0020) +} auModeStates_t; + +static auModeStates_t mode; +auModeStates_t G = AU_NO_MODE; +int G_int = 75, mode_int; + +void main (void) { + + if ((AU_DIAGNOSE == mode)) // && ((void ) 0 != auDiagnostics_p)) + {G = mode;} + + if ((0 == mode_int)) // && ((void ) 0 != auDiagnostics_p)) + {G_int = mode_int;} + + return; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/if.i frama-c-20111001+nitrogen+dfsg/tests/misc/if.i --- frama-c-20110201+carbon+dfsg/tests/misc/if.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/if.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,96 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main main -journal-disable + OPT: -memory-footprint 1 -val -deps -main main6 -journal-disable + / +int G,H,J; +int p, q; +int t[100]; + +int main0(void) { + G=0; + int c = 0; + if (c) G=1; else G=2; + + return c; +} + +int main1(void) +{ + if (G) ; + + return 1; +} + +int main2(void) { + int c = c?0:(c?1:2); + int d = c?1:(c?2:3); + + G = -20; + H = -30; + + if (c) {G=c; H=d;}; + +// if (d>c) G=3; else G=4; + +// if (!(d<=c)) G=3; else G=4; + + return c; +} + + +int main3(void){ + G=0; + H=1; + p = &G; + q = &H; + +// if (p==q) p=2; + + return q; +} + +int main4(void) { + int e1,e2; + int c = e1?0:((e2)?1:2); + int d = e1?1:((e2)?2:3); + + G = 20; + H = 30; + + if (d<c) {G=d; H=c; } else G=4; + +// if (!(d<=c)) G=3; else G=4; + + return c; +} + +void main(void) +{ + q = t; + p = t + G; + if ((p >= &t[10]) && (p <= &t[99])) + q = p; +} + +void def(void) +{ + if (J) + G = H; +} + +int main5(void) +{ + G = 0; + if (G) H=J; + + return 1; +} + +int main6(int c, int d) +{ + G = 0; + if (G) if (d) G=2; else G = 1; + // G isn't modified + return 1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/implies.i frama-c-20111001+nitrogen+dfsg/tests/misc/implies.i --- frama-c-20110201+carbon+dfsg/tests/misc/implies.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/implies.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +int A,B; + +int main(int c, int d) +{ + A = !!d; + /@ assert ((A ==> \false) ==> \false); / + + /@ assert c ==> \false; / + return 1 + c; + +} \ No newline at end of file diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/incorrect_reduce_expr.i frama-c-20111001+nitrogen+dfsg/tests/misc/incorrect_reduce_expr.i --- frama-c-20110201+carbon+dfsg/tests/misc/incorrect_reduce_expr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/incorrect_reduce_expr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/ run.config + OPT: -memory-footprint 1 -val -absolute-valid-range 32-36 +/ + +char t[5]; +int p; +int x; +void main(int c) +{ + x = 13; + p = (int)32; + if (c) p+=1; + (char)p = 13; +} + + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/infinite.i frama-c-20111001+nitrogen+dfsg/tests/misc/infinite.i --- frama-c-20110201+carbon+dfsg/tests/misc/infinite.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/infinite.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +int G; +void main () { + int count; + G++; + if (G==1) + while(1) { + G++; + if(G==5) break; + pause(3); + G--; + }; + G=0; + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/init_from_cil.i frama-c-20111001+nitrogen+dfsg/tests/misc/init_from_cil.i --- frama-c-20110201+carbon+dfsg/tests/misc/init_from_cil.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/init_from_cil.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,7 @@ +/ run.config + OPT: -load-script tests/misc/init_from_cil.ml +/ + +int f(int x); + +int main () { return f(0); } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/init.i frama-c-20111001+nitrogen+dfsg/tests/misc/init.i --- frama-c-20110201+carbon+dfsg/tests/misc/init.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/init.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,18 @@ +const char S[5] = "12345"; + +struct t1 { int x; int y; int name[10];} v1; +struct t1 TS[29] = {1,3,01234567890}; +struct t2 { int x2; short int y2; char ptr;} v2; +char C; +char PC[]= "lkjlj"; +struct t2 T2[50] = {{1,2,&PC[0]},{1,2,0}}; + +int T[10] = {1,0}; +int U[] = {3,4}; +int x = sizeof(U); +int y = sizeof(T); + + +int main (void) { + return sizeof(U); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/initialized.c frama-c-20111001+nitrogen+dfsg/tests/misc/initialized.c --- frama-c-20110201+carbon+dfsg/tests/misc/initialized.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/initialized.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,17 @@ +extern int b1, b2, b3; + +int main () { + int r1, x1, x2, r2, x3, r3; + + if (b1) x1 = 1; + //@ assert \initialized(&x1); + r1 = x1+1; + + if (b2) + x2 = r2 + 1; + + if (b3) x3 = 1; + r3 = x3 + 1; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/inout_formals.i frama-c-20111001+nitrogen+dfsg/tests/misc/inout_formals.i --- frama-c-20110201+carbon+dfsg/tests/misc/inout_formals.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/inout_formals.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +/run.config + OPT: -inout -input-with-formals -inout-with-formals +/ +int x, y; + +void main(int * const i) { + i=0; + if (i==x) i=y; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/inout.i frama-c-20111001+nitrogen+dfsg/tests/misc/inout.i --- frama-c-20110201+carbon+dfsg/tests/misc/inout.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/inout.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,69 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -inout -deps -main inout_11_0 -journal-disable + OPT: -memory-footprint 1 -inout -deps -main inout_11_3 -journal-disable + OPT: -memory-footprint 1 -inout -deps -main never_terminate -journal-disable + OPT: -memory-footprint 1 -inout -deps -main may_not_terminate -journal-disable + OPT: -memory-footprint 1 -inout -deps -main call_may_not_terminate -journal-disable +/ + +int Xt, Xs, Xs_I, Ys, Ys_I, Z, I; + +void inout_11_0 (int i1, int i2, int i) { + Xs_I = Xs_I + 1; + Xt = I ; + Xs = i1 ; + Ys = i1 + i2 ; + + i = 0; + Z = i; +} + + +const int I_size=8; + +const int Itab[8]={-40,-25,-15,-5,5,15,25,40}; +int inout_11_3 (int i1, int es, int i2) { + int r; + es = i1 ; + Xs = es ; + + if (i2 < Itab[0]) + r=-2; + else + if (i2>=Itab[I_size-1]) + r=-1; + else + for(Z=0;Z<I_size-1;Z++) + { + if ((i2>=Itab[Z])&&(i2<Itab[Z+1])) + r=Z; + } + return r; +} + +void never_terminate (int i1_nt, int i2_nt, int i3_nt, int es, int e) { + Xs = i1_nt; + es = i2_nt ; + Xs = es ; + Xs = i3_nt ; + while (1) ; + Z = e ; +} + +int I5_nt ; +void may_not_terminate (int i1, int i2, int i3, int i4, int i5_nt, int es, int e) { + Xs = i1; + es = i2 ; + if (i4) { + Xs = i5_nt + I5_nt ; + while (1) ; + Z = e ; + } + Xs = es ; + Xs = i3 ; +} + +void call_may_not_terminate (int j1, int j2, int j3, int j4, int j5, int c1, int c2) { + may_not_terminate(j1, j2, j3, j4, j5, c1, c2) ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/inout_proto.i frama-c-20111001+nitrogen+dfsg/tests/misc/inout_proto.i --- frama-c-20110201+carbon+dfsg/tests/misc/inout_proto.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/inout_proto.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,20 @@ +/run.config + OPT: -inout -input-with-formals -inout-with-formals +/ + +typedef unsigned char BYTE; +typedef BYTE * MESSAGE_ADDR_TYPE; + + +//@ assigns RETURN_CODE \from MESSAGE_ADDR[0..length], length; +extern void SendBuffer + (const MESSAGE_ADDR_TYPE / Array / / in / MESSAGE_ADDR, + const int / in / length, + int const /* out / RETURN_CODE); + + +void main(const MESSAGE_ADDR_TYPE msg) +{ + int ret; + SendBuffer((MESSAGE_ADDR_TYPE) &msg, 4, &ret); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/input.i frama-c-20111001+nitrogen+dfsg/tests/misc/input.i --- frama-c-20110201+carbon+dfsg/tests/misc/input.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/input.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +int f(int x, ...); + +int a,b; + +int main () { + + return f(a,b); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/invalid_access.i frama-c-20111001+nitrogen+dfsg/tests/misc/invalid_access.i --- frama-c-20110201+carbon+dfsg/tests/misc/invalid_access.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/invalid_access.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +int t[10]; +int x,p,y,z; + +void main (int c,int d) { + p=d?t:(t+1); + p[0]=5; + p[1]=6; + p[2]=5; + z = p[!d]; +/* p[3]=5; + p[4]=5; + p[5]=5; + p[6]=5; + p[7]=5; + p[8]=5; + p[9]=5;/ +/ y=p[1]; + if (c>=0 && c <=15) x = p[c];/ +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/invalid_lval_arg.i frama-c-20111001+nitrogen+dfsg/tests/misc/invalid_lval_arg.i --- frama-c-20110201+carbon+dfsg/tests/misc/invalid_lval_arg.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/invalid_lval_arg.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +void f(int); + +int X; + +void g(int x) +{ + X = x + 1; +} + +void (p)(int); + +main(int c){ + p = c&1? f : g; + if (c&2) + f((int)0); + else if (c&4) + g((int)0); + else + p((int)0); + return X; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/inversion2.i frama-c-20111001+nitrogen+dfsg/tests/misc/inversion2.i --- frama-c-20110201+carbon+dfsg/tests/misc/inversion2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/inversion2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +int T[3] = {3,1,2}; +int TT[3][5] = {{3,3,3,0,0}, {1,0,0,0,0}, {2,2,0,0,0}}; + +void main() { + int i,j=77,G=99; + for (i=0 ; i < 3 ; i++) { + for (j=0; j < T[i]; j++) + G = 15/(TT[i][j]);}; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/inversion.i frama-c-20111001+nitrogen+dfsg/tests/misc/inversion.i --- frama-c-20110201+carbon+dfsg/tests/misc/inversion.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/inversion.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,47 @@ + +int x = 0; +int y = 0; +int z = 0; +int pz = &z ; +int px = &x ; +int py = &y ; + +int X = 0; +int pX; + +struct s +{ int ok; + int p; } t[5]={ {0,0}, {1,&pz}, {1,&py} , {0,0} }; + +struct s t2[5]={ {0,0}, {0,0}, {1,&px}, {0,0} }; +int ii[2]; + +void main(void) +{ + int i; volatile int k=0; + pX = k ? 0 : &X; + for (i=0 ; i < 5; i++) + { + if (t[i].ok) + (t[i].p) = i; + X = i; + } + + for (ii[1]=0 ; ii[1] < 5; ii[1]++) + { + if (t2[ii[1]].ok) + **(t2[ii[1]].p) = ii[1]; + X = ii[1]; + } +} + +void g (void) +{ + int c = -25; + + + while (c) + { + c++; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/jacques.i frama-c-20111001+nitrogen+dfsg/tests/misc/jacques.i --- frama-c-20110201+carbon+dfsg/tests/misc/jacques.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/jacques.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,42 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable +/ + +int t[4]; + +int p; +int q; + +void f(void) +{ + p = 4; + q = 5; +} + +int A,B,C; +void main(int a, int b, int pp) +{ + + CEA_f(pp); + + //@ assert \valid(pp); + + CEA_f(pp); + + pp = 5; + + //@ assert pp + 1 == 6; + + A = 10; + B = 11; + + p = &A; + q = &B; + f(); + + p = &A; + q = &A; + f(); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/join_misaligned.i frama-c-20111001+nitrogen+dfsg/tests/misc/join_misaligned.i --- frama-c-20110201+carbon+dfsg/tests/misc/join_misaligned.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/join_misaligned.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,27 @@ + +int t[5]={0}; +int u[5]={1,1,1,1,1}; +int v[7]={1,1,1,1,1,1,1}; +int w[7]={0}; +char x[5]={0}; + +void main(int c) +{ + if (c) + { + ((char)t)[6]='a'; + ((char)u)[6]='c'; + ((short)((char)v+6))=27; + ((short)((char)w+6))=57; + } + else + { + ((char)t)[6]='b'; + ((char)u)[6]='d'; + ((short)((char)v+7))=29; + ((short)((char)w+7))=59; + x[0]=1; + x[1]=0; + x[2]=1; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/label.i frama-c-20111001+nitrogen+dfsg/tests/misc/label.i --- frama-c-20110201+carbon+dfsg/tests/misc/label.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/label.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,44 @@ +/* run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable +/ +int a,b,d,e,i,p,q; + +void f(int, int); + +void main(int c) +{ + b = 1; + if (c) p = &a; else p = &b; + p = 2; + + a = (int)(&d + 1); + + q = &a; + + L: ((char)&p+i) = ((char)&q+i); + i++; + if (i<4) goto L; +/ + p = (int) &e; + + f(0, &i); + + f(1, &a); + + f(0, &a); +/ + return; +} + +void f(int x, int r) +{ + a = x; + (r)++; + if (x - a != 0) + p = a; + + q = x ? &a : (int)0; + + //@ assert \valid(q); + q = b; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/lazy.i frama-c-20111001+nitrogen+dfsg/tests/misc/lazy.i --- frama-c-20110201+carbon+dfsg/tests/misc/lazy.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/lazy.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +/ run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -undefined-pointer-comparison-propagate-all +/ +int a=-1; +int b, d; +int q, r, s, t; +void main (int p, int c, int d) { + + q = &a - !c; + if (q) r=q; + + s = &a - !d; + if (!s) t=s; + + if (p && p ) p = 0 ; + if (&a) { a=0; b=1; } + if (&a+1) a+=2; + if (&a+2) a+=4; + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/leaf2.i frama-c-20111001+nitrogen+dfsg/tests/misc/leaf2.i --- frama-c-20110201+carbon+dfsg/tests/misc/leaf2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/leaf2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +typedef int T; +extern T f(char* p,int q, int i); + +T G,H,I; +void main (void) { + G = f(&H,(int)&I,17); + if (G == -1) G++; + + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/leaf.i frama-c-20111001+nitrogen+dfsg/tests/misc/leaf.i --- frama-c-20110201+carbon+dfsg/tests/misc/leaf.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/leaf.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,70 @@ +int T[30] = {1}; + +int f_int_int(int x); +int * f_int_star_int(int x); +int **f_int_star_int_star_int(int x); + +int f_star_int_cint(const int x); + +/ 3 identicals prototypes / +int f_star_int_int(int x); +int f_tab_int_int(int x[]); +int f_tab3_int_int(int x[3]); + +int cv1=10, cv2=20, cv3=30 ; +struct _st_star_cint { const int * const p ; } + st_star_cint_1={&cv1}, + st_star_cint_2={&cv2}, + st_star_cint_3={&cv3} ; + +int v1=10, v2=20, v3=30 ; +struct _st_star_int { int * p ; } + st_star_int_1={&v1}, + st_star_int_2={&v2}, + st_star_int_3={&v3} ; + +struct _st_tab3_int { int t[3] ; } + st_tab3_int_1={10, 11, 12}, + st_tab3_int_2={20, 21, 22}, + st_tab3_int_3={30, 31, 32} ; + +struct _st_star_cint f_st_star_cint_st_star_cint(struct _st_star_cint s) ; +struct _st_star_int f_st_star_int_st_star_int (struct _st_star_int s) ; +struct _st_tab3_int f_st_tab3_int_st_tab3_int (struct _st_tab3_int s) ; + +int f_star_st_star_cint_int (struct _st_star_cint * s) ; +int f_star_st_star_int_int (struct _st_star_int * s) ; +int f_star_st_tab3_int_int (struct _st_tab3_int * s) ; + +void main() { + int c,d; + T[0]=f_int_int(0); /* T[0] modified / + + int p = f_int_star_int(0); + CEA_F(p); + p = 5; + CEA_F(*p); + + int **pp =f_int_star_int_star_int(0); + CEA_G(*pp); + CEA_F(**pp); +// if (*pp==&d) **pp = 6; + CEA_G(*pp); + CEA_F(**pp); + + T[2]=f_star_int_cint(&T[3]); /* T[2] modified / + + f_star_int_int(&(T[4])); / only T[4] modified / + f_tab3_int_int(&T[6]); / only T[6..8] modified / + f_tab_int_int(&T[10]); / only T[10] modified / + + st_star_cint_1 = f_st_star_cint_st_star_cint(st_star_cint_2); / only st_star_cint_1 modified / + st_star_int_1 = f_st_star_int_st_star_int (st_star_int_2) ; / st_star_int_1 modifed, v2 SHOULD BE modified / + st_tab3_int_1 = f_st_tab3_int_st_tab3_int (st_tab3_int_2) ; / only st_tab3_int_1 modified / + + f_star_st_star_cint_int(&st_star_cint_3); / st_star_cint_3.p modified / + f_star_st_star_int_int (&st_star_int_3) ; / v3 SHOULD BE modified / + f_star_st_tab3_int_int (&st_tab3_int_3) ; / st_tab3_int_3 SHOULD BE modified / + +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/leaf_spec.i frama-c-20111001+nitrogen+dfsg/tests/misc/leaf_spec.i --- frama-c-20110201+carbon+dfsg/tests/misc/leaf_spec.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/leaf_spec.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,28 @@ +/ run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main1 -journal-disable +/ + +void f(int x, int * y, int **z, int a, char b); + + +void f1(int y); + +int g(int x); + +int h(int y); + +int k( int l); +int k0( int const l); + +void main () { + f1(0); + g(2); + h(0); + k(0);k0(0); +} + +void main1(void) +{ + f(0,0,0,0,0); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/library.i frama-c-20111001+nitrogen+dfsg/tests/misc/library.i --- frama-c-20110201+carbon+dfsg/tests/misc/library.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/library.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main main -context-depth 3 -journal-disable +/ +int f_int(int x); +int f_star_int(int x); + +int ****G; + +int G0,G1; +void main(void) { + G0 = f_int(2); + G1 = f_star_int(5); + G1 = 5; + ****G=1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/limits.c frama-c-20111001+nitrogen+dfsg/tests/misc/limits.c --- frama-c-20110201+carbon+dfsg/tests/misc/limits.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/limits.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,31 @@ +/* run.config + OPT: -memory-footprint 1 -val -journal-disable -val-signed-overflow-alarms -cpp-command "gcc -C -E -nostdinc -I. -Ishare/libc" +/ +#include <limits.h> + +int cl, cu, ucu; +int il, iu, uiu; +long ll, lu; +unsigned long ulu; +long long lll, llu; +unsigned long long ullu; + +main() +{ + cl = CHAR_MIN; + cu = CHAR_MAX; + ucu = UCHAR_MAX; + + il = INT_MIN; + iu = INT_MAX; + uiu = UINT_MAX; + + ll = LONG_MIN; + lu = LONG_MAX; + ulu = ULONG_MAX; + + lll = LLONG_MIN; + llu = LLONG_MAX; + ullu = ULLONG_MAX; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/local.i frama-c-20111001+nitrogen+dfsg/tests/misc/local.i --- frama-c-20110201+carbon+dfsg/tests/misc/local.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/local.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,30 @@ +int X, Y, Z, T, U, V; + +int f(void) +{ + int a,b,c; + X = &a; + return &b; +} + +int g(void) +{ + volatile int d=0; + T = f(); + U = d ? T : &d; + return U; +} + +int h(int x) +{ + return x+1; +} + +void main(void) +{ + int e; + Y = f(); + Z = g(); + Frama_C_dump_each(); + V = h(&e); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/local_variables.i frama-c-20111001+nitrogen+dfsg/tests/misc/local_variables.i --- frama-c-20110201+carbon+dfsg/tests/misc/local_variables.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/local_variables.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,48 @@ +/ run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -inout +/ + +int A,B,C,D,R,S; + +int u() +{ + int ru, wu; + ru = C; + return w(&ru, &wu); +} + +int v() +{ + int rv, wv; + rv = D; + return w(&rv, &wv); +} + +int w(int pr, int pw) +{ + pw = A; + if (unkn()) B = pr; + return pr; +} + +int main (int c, int * p) { + + R=u(); + S=v(); + + if (c) { + int x = 1; + p = &x; + } + { + int y = 0; + { int z = 1; + int t = y + z; + } + } + for (int i = 0; i<5; i++) { + int a = 0; + a += i; + } + return p; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/lock.i frama-c-20111001+nitrogen+dfsg/tests/misc/lock.i --- frama-c-20110201+carbon+dfsg/tests/misc/lock.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/lock.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,53 @@ +/ run.config + STDOPT: +"-main locks0_good" + / + +/@ ghost int ghost_loctable[100] ;/ + +/@ axiomatic Locked { + @ predicate locked{L}(struct mutex m); + @ // reads m, ghost_loctable[..] ; + @ + @ axiom locked_dummy_axiom_for_reads{L} : + @ \forall struct mutex m; + @ locked(m) && ghost_loctable[0] == 0 ==> + @ locked(m) && ghost_loctable[0] == 0 ; + @ } + @/ + +/@ + requires !(locked(m)); + ensures locked(m); + assigns ghost_loctable[0..99]; + + / +void acquire_lock(struct mutex m); + +/@ + requires locked(m); + ensures !(locked(m)); + assigns ghost_loctable[..]; + + / +void release_lock(struct mutex m); + +/@ + requires !(locked(m)); + assigns ghost_loctable[..]; + behavior success: + ensures (\result != 0) ==> locked(m); + + behavior failure: + ensures (\result == 0) ==> !(locked(m)); + + / +int try_acquire_lock(struct mutex m); + +struct mutex pmutex; + +/@ requires !(locked(pmutex)); / +void locks0_good(int flag) +{ + acquire_lock(pmutex); + release_lock(pmutex); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/logtrap.i frama-c-20111001+nitrogen+dfsg/tests/misc/logtrap.i --- frama-c-20110201+carbon+dfsg/tests/misc/logtrap.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/logtrap.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,6 @@ +/ run.config + DONTRUN: waiting ocaml 3.12 +/ +// OPT: -load-script tests/misc/logtrap.ml +// Should raise an assertion-failure exception. + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/logtrap.ml frama-c-20111001+nitrogen+dfsg/tests/misc/logtrap.ml --- frama-c-20110201+carbon+dfsg/tests/misc/logtrap.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/logtrap.ml 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +let main () = + begin + Log.print_on_output + (fun fmt -> + Format.fprintf fmt "Start.@." ; + if true then assert false ; + Format.fprintf fmt "End.@." ; + ) + end + +let () = Db.Main.extend main diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/long_const.i frama-c-20111001+nitrogen+dfsg/tests/misc/long_const.i --- frama-c-20110201+carbon+dfsg/tests/misc/long_const.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/long_const.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,6 @@ +void main() { + unsigned long long i; + i = 0xFFFF804000000000UL; + unsigned long j= ((((((256ULL) >> 8) 0xffff000000000000UL) | (256ULL << 39) )) + (1ULL << 39)/2ULL); + CEA_f(sizeof(long),i,j); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/long.i frama-c-20111001+nitrogen+dfsg/tests/misc/long.i --- frama-c-20110201+carbon+dfsg/tests/misc/long.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/long.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ + +int i,j,k; + +void f(void) +{ + for (i=0;i<1000;i++); +} + +void main(void) +{ + for (j=0;j<1000;j++) + f(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/long_ident.c frama-c-20111001+nitrogen+dfsg/tests/misc/long_ident.c --- frama-c-20110201+carbon+dfsg/tests/misc/long_ident.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/long_ident.c 2011-10-10 08:39:03.000000000 +0000 @@ -6,7 +6,6 @@ / int f(int q) ; - #define LV X_9999999999999999999999999999999999999999999999999999 int LV; enum { OK = 1, diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop1.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop1.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop1.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +char U[100]={1, 2}; +char NULL_GLOBAL_LOOSING_BITS_ONE_BY_ONE = 0; +int main () { + int i; + for(i=0;i<=100; i++) + { + U[i]=7; + } + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop2.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop2.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,83 @@ +int i,j,k,l,n,r; +struct T {int a,b;} G[5]={0}; + +void g(const int b) ; + +void main() { + n=5; + for (i=0; i<n ; i++) + { + G[i].a = i+55; + G[i].b = i+57; + } +} + + +static char Reg5; +void g(const int b) { + Reg5 = Reg5 & (~(0x80)); +} + +void main1(void) +{ + + { + n = 1; + i = 0; + { + { + { + + + if (i < n) { + + } else { + goto while_0_break; + } + G[i].a = 1; + i += 1; + + + if (i < n) { + + } else { + goto while_0_break; + } + G[i].a = 1; + i += 1; + while (1) { + while_1_continue: /* CIL Label / ; + while_0_continue: / CIL Label / ; + if (i < n) { + + } else { + goto while_0_break; + } + G[i].a = 1; + i += 1; + } + } + while_1_break: / CIL Label / ; + } + while_0_break: / CIL Label / ; + } + + return; +} +} + + +void main2(void) +{ + main(); + l1: + main1(); + l2: + g(0); + if(i) goto l1; + k=0; + if(j) goto l2; + l=0; + +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_annot.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_annot.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_annot.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_annot.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +/ run.config + OPT: -simplify-cfg -keep-switch -print -check -journal-disable + OPT: -simplify-cfg -print -check -journal-disable +/ + +void f() { + int i = 0; + //@ loop invariant 0 <= i <= 10; + while (i < 10) { // @ invariant 0 <= i < 10; + ++i; + //@ assert 0 <= i <= 10; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_array.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_array.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_array.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_array.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,23 @@ +long long T[10000]; +int U[10000]; +void main () { + int i,j; + for (i=0;i<5; i++) + T[i] = 2; + + for (j=6;j<10000; j++) + T[j] = 7; + + i=0; + while(1) + { + U[i]=0; + if (i == 200) U[i]=-1; + i = 1000 - i; + if (i < 500) + i++; + if (i == 400) + goto l_end_loop; + } + l_end_loop: +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,96 @@ +int i,j,k,n,r; + +void main() { + int i; + r=0; + n=50; + for (i=0; i<n ; i+=2) { + CEA_F(i); + r = i+r; } +} + +void main1() { + r=2; + k=j?0:1;/ ICI 1 / + if (k) i = 1; else i = 4; + + if (i<2) i+=r; + +} + +void main2() { + int i,j,k; + r = 0; + n = 0; + for (i=0; i<(n+1) ; i++) +/ ICI 2 / + for (j=0; j <(n+1) ;j / ICI 3 / ++) + for (k=0; k <(n+1); k++) + r = i+j+k+r+1;/ ICI 4 / +} + +/ Infinite non trivial loop / +void main3() { + int i; + r = 0; + n = 0; + for (i=0; i<(n+1) ; ) + r = i+1; +} + +void main4(void) +{ + i = 0; + j= 0; + while(1) + { + k = i; + if (i < j) break; + k = r; + } + / k does not depend on r when exiting this loop. / +} + +int G; + +void main5(void) +{ int i_0 ; + + { + G = -1; + r = 0; + n = 2; + i_0 = 1; + { + while (1) +{ + while_0_continue: / CIL Label / ; + if (i_0 < n+1 ) { + G=0; + r = r+1; + i_0 += 1; + } else { + G=1; + goto while_0_break; + } + } + while_0_break: / CIL Label / ; + } + + return; + } +} + + +void main6() { + int i, b; + r=0; + n=5; + + for (i=0; i<n ;) { + r = i+r; + if (b) i--; + b = b&&b; + if (r<b) i+=3; else i+=6; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loopinv.c frama-c-20111001+nitrogen+dfsg/tests/misc/loopinv.c --- frama-c-20110201+carbon+dfsg/tests/misc/loopinv.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loopinv.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,27 @@ +/ run.config +OPT: -pp-annot -val -then -report +/ + +/@ requires \valid(&t[0..s-1]); + requires 1 <= c < s; / +void init (int t, int c, int s) { + int* p = t; + /@ loop invariant p < &t[s-1]; / + while(1) { + (++p) = 1; + if(p >= t+c) break; + } +} + + +void main (int c) { + int t1[72]; + int t2[11]; + + if (c >= 1 && c < 72) { + init(t1, c, 72); + + if (c < 8) + init(t2, c, 11); + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_join.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_join.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_join.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_join.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +int U[10000]; +void main () { + int i; + i=0; + while(1) + { + U[i]=0; + if (i == 200) U[i]=-1; + i = 1000 - i; + if (i < 500) + i++; + if (i == 400) + goto l_end_loop; + } + l_end_loop: +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_long.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_long.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_long.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_long.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +char T[368200]; + +int main(int c1, int c2) { + int i; + for(i = 0; i < 368; i++) { + T[i] = 33; + } + return i; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_no_var.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_no_var.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_no_var.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_no_var.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,4 @@ +int main() +{ + while(1) {} +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_simple.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_simple.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_simple.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_simple.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,29 @@ +int i,j,k,n,r; + +#if 0 +void main2() { + r=0; + goto L; + n=5; + + for (int i=0; i<n ; i++) { + L: + r = i+r; + if(r && n-- || n++ && n--) r=99; + + } + + r=10; +} +#endif + +int main() { + r = 0; + k= 0 ; + n = 2; + for (i=0; i<n; i++) + for (j=0;j<n; j++) + for (k=0; k<n; k++) + r = i+j+k+r+1; + return r; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_test.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_test.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_test.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_test.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,111 @@ +/ run.config + DONTRUN: cannot find entry point: cent_onzes + OPT: -memory-footprint 1 -val -main test_onzes -journal-disable + OPT: -memory-footprint 1 -val -main cent_onzes -journal-disable +*/ + +/*** var CMP cste / +int onze_0 (void) { + int onze; for (onze=1000; onze >= 12 ; onze--) ; return onze ; +} +int onze_1 (void) { + int onze; for (onze=1000; onze > 11 ; onze--) ; return onze ; +} +int onze_2 (void) { + int onze; for (onze=0; onze < 11 ; onze++) ; return onze ; +} +int onze_3 (void) { + int onze; for (onze=0; onze <= 10 ; onze++) ; return onze ; +} +int onze_4 (void) { + int onze; for (onze=0; onze != 11 ; onze++) ; return onze ; +} +/* cste CMP var ******/ +int onze_5 (void) { + int onze; for (onze=1000; 12 <= onze ; onze--) ; return onze ; +} +int onze_6 (void) { + int onze; for (onze=1000; 11 < onze; onze--) ; return onze ; +} +int onze_7 (void) { + int onze; for (onze=0; 11 > onze; onze++) ; return onze ; +} +int onze_8 (void) { + int onze; for (onze=0; 10 >= onze; onze++) ; return onze ; +} +int onze_9 (void) { + int onze; for (onze=0; 11 != onze; onze++) ; return onze ; +} + +int r0,r1,r2,r3,r4,r5,r6,r7,r8,r9; +void test_onzes(void) +{ + r0 = onze_0(); + r1 = onze_1(); + r2 = onze_2(); + r3 = onze_3(); + r4 = onze_4(); + r5 = onze_5(); + r6 = onze_6(); + r7 = onze_7(); + r8 = onze_8(); + r9 = onze_9(); +} + +/* !(var CMP cste) ******/ +int cent_onze_0 (void) { + int cent_onze; for (cent_onze=1000; !(cent_onze < 112) ; cent_onze--) ; return cent_onze ; +} +int cent_onze_1 (void) { + int cent_onze; for (cent_onze=1000; !(cent_onze <= 111) ; cent_onze--) ; + return cent_onze ; +} +int cent_onze_2 (void) { + int cent_onze; for (cent_onze=0; !(cent_onze >= 111) ; cent_onze++) ; + return cent_onze ; +} +int cent_onze_3 (void) { + int cent_onze; for (cent_onze=0; !(cent_onze > 110) ; cent_onze++) ; + return cent_onze ; +} +int cent_onze_4 (void) { + int cent_onze; for (cent_onze=0; !(cent_onze == 111) ; cent_onze++) ; + return cent_onze ; +} +/* !(cste CMP var) ******/ +int cent_onze_5 (void) { + int cent_onze; for (cent_onze=1000; !(112 > cent_onze) ; cent_onze--) ; return cent_onze ; +} +int cent_onze_6 (void) { + int cent_onze; for (cent_onze=1000; !(111 >= cent_onze) ; cent_onze--) ; + return cent_onze ; +} +int cent_onze_7 (void) { + int cent_onze; for (cent_onze=0; !(111 <= cent_onze) ; cent_onze++) ; + return cent_onze ; +} +int cent_onze_8 (void) { + int cent_onze; for (cent_onze=0; !(110 < cent_onze) ; cent_onze++) ; + return cent_onze ; +} +int cent_onze_9 (void) { + int cent_onze; for (cent_onze=0; !(111 == cent_onze) ; cent_onze++) ; + return cent_onze ; +} + +/* **************/ + +int c0,c1,c2,c3,c4,c5,c6,c7,c8,c9; +void test_cent_onzes(void) +{ + c0 = cent_onze_0(); + c1 = cent_onze_1(); + c2 = cent_onze_2(); + c3 = cent_onze_3(); + c4 = cent_onze_4(); + c5 = cent_onze_5(); + c6 = cent_onze_6(); + c7 = cent_onze_7(); + c8 = cent_onze_8(); + c9 = cent_onze_9(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/loop_wvar.i frama-c-20111001+nitrogen+dfsg/tests/misc/loop_wvar.i --- frama-c-20110201+carbon+dfsg/tests/misc/loop_wvar.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/loop_wvar.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,43 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -no-annot -val -journal-disable + OPT: -memory-footprint 1 -val -journal-disable + OPT: -memory-footprint 1 -val -main main_err1 -journal-disable + OPT: -memory-footprint 1 -val -main main_err2 -journal-disable +/ + +int i,j; + +void main(void) +{ int n = 13; +// ceci �tait une annotation, mais on ne fait pas moins bien sans +// maintenant: +// loop pragma WIDEN_VARIABLES i; + /@ loop pragma WIDEN_HINTS i, 12, 13; / + for (i=0; i<n; i++) + { + j = 4 i + 7; + } +} + + +void main_err1(void) +{ int n = 13; + /@ loop pragma WIDEN_HINTS 12 ; / + for (i=0; i<n; i++) + { + j = 4 * i + 7; + } +} + + + + +void main_err2(void) +{ int n = 13; + /@ loop pragma WIDEN_VARIABLES 12; / + for (i=0; i<n; i++) + { + j = 4 * i + 7; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/m12_2.i frama-c-20111001+nitrogen+dfsg/tests/misc/m12_2.i --- frama-c-20110201+carbon+dfsg/tests/misc/m12_2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/m12_2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,91 @@ +/* run.config + OPT: -unspecified-access +/ +// Misra C Enforcement Testing +// +// Rule 12.2 Required +// The value of an expression shall be the same under any order of +// evaluation that the standard permits. +// 1 exp arithmetique qui n'est pas un appel de fct, &&, |-, ?: ni "," +// est evaluee dans un ordre indeterminé. On ne doit pas se baser sur l'ordre +// d'evaluation des termes de ces expressions +// 12.2.1: si un terme d'une exp est un operateur d'increment ou de decrement +// d'une var alors les autres termes ne doivent ni lire ni ecrire cette variable +// 12.2.2: l'ordre d'evaluation des args d'un appel de fct etant indefini, il +// faut que pour toute paire d'args (a,b) wr(a) inter rd(b)=0 et +// rd(a) inter wr(b)=0 +// 12.2.3: +// 12.2.4: +// 12.2.5: +// 12.2.6: +/// + +typedef int SI_32; + +static void func46 ( SI_32 m, SI_32 n ) ; + +static SI_32 func46a ( SI_32 m, SI_32 n ) +{ + return m + n; +} + +static struct st +{ +int st_m; +int st_n; +} local_st; + +SI_32 main ( void ) +{ + + SI_32 i = 3; + SI_32 x = 3; + SI_32 y = 3; + SI_32 z = 3; + + struct st this_st; + + this_st.st_m = 1; + this_st.st_n = 2; + + z = ( y=i,++y ) + i++; // RULE 12.2.1: is est lu dans l'autre terme + + z = ++i + ( y=x,++y ) ; // y n'est PAS lu dans un autre terme + + z = ++i + ( y=i,++y ) ; // RULE 12.2.1: i est lu dans un autre terme + + z = ++i + ( 1 || i++ ) ; + + y = func46a ( x, ( x=3,x++ ) ) ; // RULE 12.2.2: x est lu dans le terme de G + + y = func46a ( x, ( i=2,i+3 ) ) ; // pas de conflits entre arguments effectifs + + z = i + i++; // RULE 12.2.1 + + z = ( y=x,++y ) + i++; + + z = ( i = 3 ) + i + 8; // RULE 12.2.5 + + z = ( this_st.st_m = 3 ) + + this_st.st_m + 8; // RULE 12.2.5 + + z = ( this_st.st_m = 3 ) + + this_st.st_n + 8; + + z = ++i + ( ( y += 2,y ) ,y++ ) ; // pas de conflits + + z = ( ( ++i+i ) >0 ) ? ++i : --i;// RULE 12.2.1: conflits entre terme du + + + z = ( i>0 ) ? ++i : --i; + + z = ++i + ( 381 && i++ ) ; // RULE 12.2.1: conflits entre terme du + + + z = ++i + ( y, y++ ) ; + + z = ++i + ( 380 || i++ ) ; // RULE 12.2.1: idem + + z = ++i + ( i, y++ ) ; // le resultat de terme droit ne depend pas de i + + return z; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/memcpy.c frama-c-20111001+nitrogen+dfsg/tests/misc/memcpy.c --- frama-c-20110201+carbon+dfsg/tests/misc/memcpy.c 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/memcpy.c 2011-10-10 08:39:03.000000000 +0000 @@ -1,12 +1,46 @@ +/ run.config + STDOPT: +"-slevel-function" +"init:20" +"-then" +"-report" +/ #include "share/builtin.h" + +extern int b; +extern unsigned int i; + +char src[20]; +char dst1[20], dst2[20], dst3[20]; +char dst4[20]; + +void init () { + for (int j=0;j<20;j++) { + src[j] = j+1; + dst1[j] = -1; + dst2[j] = -1; + dst3[j] = -1; + dst4[j] = -1; + } +} + + struct t1 { int x; int y; int p;} v1,v2, v3; struct t1 t[4]; -int main (int a, int b){ +void main (int a, int b){ + init (); + + //@ assert 5 <= b && b <= 15; + Frama_C_memcpy(dst1+1, src+2, b); + + Frama_C_memcpy(dst2+1, src+2, 2b); + + //@ assert 5 <= b && b <= 14; + Frama_C_memcpy(dst3+5, src+2, b); + + Frama_C_memcpy(dst4+5, src+2, 2b); + v2 = v2; v2.p = &v1.y; t[1]=v2; - + v1.x = 5; v1.y = 7; Frama_C_memcpy(&v2, &v1, sizeof(v1)); @@ -15,5 +49,5 @@ Frama_C_memcpy(&v3, t+(int)t, sizeof(v1)); - Frama_C_memcpy(&v2 + (int)&v2, &v1, sizeof(v1)); + // Frama_C_memcpy(&v2 + (int)&v2, &v1, sizeof(v1)); } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/merge_bits.i frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bits.i --- frama-c-20110201+carbon+dfsg/tests/misc/merge_bits.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bits.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +char T[] = { 1,0,0,0,1,2,3,4,5,0,1,1,1 } ; +int main() { + CEA_F(((int)(T))); + CEA_F(((int)(T+1))); + CEA_F(((int)(T+4))); + CEA_F(((int)(T+9))); + ((int)(T+2))=2<<31 | 2 << 30 | 2 << 27 | 2 << 3; + CEA_F(((int)(T))); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/merge_bts0948_1.i frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bts0948_1.i --- frama-c-20110201+carbon+dfsg/tests/misc/merge_bts0948_1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bts0948_1.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,6 @@ +/* run.config + DONTRUN: main test is merge_bts0948.i +/ + +/@ requires \valid((char)dest_1); / +extern void memcpy(void dest_1); diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/merge_bts0948_2.i frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bts0948_2.i --- frama-c-20110201+carbon+dfsg/tests/misc/merge_bts0948_2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bts0948_2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,6 @@ +/* run.config + DONTRUN: main test is merge_bts0948.i +/ + +/@ requires \valid((char)dest_2); / +extern void memcpy(void dest_2); diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/merge_bts0948.i frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bts0948.i --- frama-c-20110201+carbon+dfsg/tests/misc/merge_bts0948.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/merge_bts0948.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +/* run.config + OPT: tests/misc/merge_bts0948_1.i tests/misc/merge_bts0948_2.i -check -print +/ + +/@ requires \valid((char)dest); +/ +extern void memcpy(void dest); + +void* memcpy(void* region1) { return region1; } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/miel.i frama-c-20111001+nitrogen+dfsg/tests/misc/miel.i --- frama-c-20110201+carbon+dfsg/tests/misc/miel.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/miel.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,102 @@ +/* run.config + DONTRUN: cannot find entry point: main +/ + +void g() { j(); +} + +void j() { j();} + +void h() { + j(); +} + +void h1() { + j(); +} + +void h2() { + j(); +} + +void h3() { + j(); +} + +void h4() { + j(); +} + +void h5() { + j(); + p0(); +} + +void l1() { + l2(); +} + +void l2() { + +} + +void r0() { + l1 (); +} +void r1() { + l1 (); +} +void r2() { + l1 (); +} +void r3() { + l1 (); +} + +/ +void ldkfadl(void) +{ + p1(); +} +/ + +void p0() { + // p1 (); +} +void p1() { + p2 (); + p3 (); + p0(); +} +void p2() { + p1 (); + p3 (); +} +void p3() { + p1 (); + p2 (); +} + + +void g0() { + g2 (); +} +void g1() { + g2 (); +} +void g2() { + g3 (); +} +void g3() { + g4 (); + g5 (); +} +void g4() { + g6 (); g3 (); +} +void g5() { + g6 (); +} +void g6() { + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/mini_pointrer.i frama-c-20111001+nitrogen+dfsg/tests/misc/mini_pointrer.i --- frama-c-20110201+carbon+dfsg/tests/misc/mini_pointrer.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/mini_pointrer.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +int T[2]; +intppp; +int pp[2]; +int p; +void main(int c) { + pp [c] = &T[c]; + if (c) ppp = &pp; else ppp = &T[-1]; + ppp=9; + + if (c>=0 && c<=5) T[c] = 4; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/misaligned_tabs.i frama-c-20111001+nitrogen+dfsg/tests/misc/misaligned_tabs.i --- frama-c-20110201+carbon+dfsg/tests/misc/misaligned_tabs.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/misaligned_tabs.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,67 @@ +char T[300]; + +struct st { short i1,i2; char c1,c2; short i3,i4 ;}; +struct st S1 = { 0x1111, 0x1111, 0x11,0x11, 0x1111, 0x1111} ; +struct st S2 = { 0x1111, 0x1111, 0x11,0x11, 0x1111, 0x1111} ; +struct st S3 = { 0x1111, 0x1111, 0x11,0x11, 0x1111, 0x1111} ; +struct st S4 = { 0x1111, 0x1111, 0x11,0x11, 0x1111, 0x1111} ; + +misaligned_struct() { + Frama_C_show_each_1 (S1.i1 == (short)&S1.c1); // ok + + ( (char )&S1.i1)= 0x11; + Frama_C_show_each_2 (S1.i1 == 0x1111); // To do + Frama_C_show_each_3 (S1.i1 == S1.i2); // To do + Frama_C_show_each_4 ((char )&S1.i1 == S1.c2); // OK + + ( (char )&S2.i1)= 0x11; + (1+(char )&S2.i1)= 0x11; + Frama_C_show_each_5 (S2.i1 == 0x1111); // ok + Frama_C_show_each_6 (S2.i1 == S2.i2); // ok + Frama_C_show_each_7 ((char )&S2.i2 == S2.c2); // OK + Frama_C_show_each_8 ((char )&S2.i2 == (char )&S4.i2); // OK + + (1+(char )&S3.i1)= 0x11; + ( (char )&S3.i2)= 0x11; + (1+(char )&S3.i2)= 0x11; + ( (char )&S3.i3)= 0x11; + (1+(char )&S3.i3)= 0x11; + ( (char )&S3.i4)= 0x11; + + ( (char )&S4.i1)= 0x11; + (1+(char )&S4.i1)= 0x11; + ( (char )&S4.i2)= 0x11; + (1+(char )&S4.i2)= 0x11; + ( (int )&S4.c1)= 0x1111; + ( (char )&S4.i3)= 0x11; + (1+(char )&S4.i3)= 0x11; + ( (char )&S4.i4)= 0x11; + (1+(char )&S4.i4)= 0x11; + + Frama_C_show_each_9 (S3.i1 == S4.i1); // To do + Frama_C_show_each_a (S3.i2 == S4.i2); // ok + Frama_C_show_each_b (S3.i3 == S4.i3); // ok + Frama_C_show_each_c (((char )&S3.i2) == ((char )&S4.i2)); // OK + Frama_C_show_each_d (S3.c1 == S4.c2); // OK + Frama_C_show_each_e (((char )&S3.i2) == S4.c1); // Ok + Frama_C_show_each_f (((char )&S3.i1) == S4.c1); // Ok +} + +int main(int c1, int c2) { + int i; + + (int)(&T[0])=c1?1:2; + (int)(&T[4])=c2?1:2; + T[1]=T[5]; + (int)(&T[8])=(int)(&T[4]); + + misaligned_struct (); +/ for(i = 0; i < 36800; i++) { + T[i] = 33; + } +/ + + if (c1) Frama_C_show_each_g (S1.i1 == (short)&S1.c1); // to do + + return i; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/mixed_val.i frama-c-20111001+nitrogen+dfsg/tests/misc/mixed_val.i --- frama-c-20110201+carbon+dfsg/tests/misc/mixed_val.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/mixed_val.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +short T[10] = {'a'}; +int a,b,c,d,e; +int main(){ + a=c?57:128073; + d=e?57:128073; + + T[0] = (short)(&a); +// T[1] = ((short)(&a)+1); + + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/modifies.i frama-c-20111001+nitrogen+dfsg/tests/misc/modifies.i --- frama-c-20110201+carbon+dfsg/tests/misc/modifies.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/modifies.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +/ run.config + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main main -journal-disable +/ + +int TAB[10]; +int G,H,J; +void main () { + if (H) {H= 3; J++;TAB[4]--;}; + if (J) G=6; + if (G) H=1; + if (H) {TAB[1]++; TAB[6]++;}; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/modulo2.i frama-c-20111001+nitrogen+dfsg/tests/misc/modulo2.i --- frama-c-20110201+carbon+dfsg/tests/misc/modulo2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/modulo2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,5 @@ + +main(int c) +{ + return 13 % (!c); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/modulo.i frama-c-20111001+nitrogen+dfsg/tests/misc/modulo.i --- frama-c-20110201+carbon+dfsg/tests/misc/modulo.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/modulo.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,20 @@ + +int A,B,C,D,E,F,G,H,I,J,K; + +void main (int i) +{ + A = (4 i) % 4; + B = (4 * i + 1) % 4; + //@ assert ((i>=-100) && (i<=100)) ; + E = (3i + 1) % 12; + //@ assert ((i>=0) && (i<=100)) ; + + C = (4 i + 1) % 4; + D = (3i + 1) % 12; + F = (24i + 5) % 12; + G = (24i + 5) % 13; + H = i % 1000; + I = (2 i+1101) % 1000; + J = (5 * i - 201) % 1000; + K = (5 * i - 201) % 10; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/multi_access.i frama-c-20111001+nitrogen+dfsg/tests/misc/multi_access.i --- frama-c-20110201+carbon+dfsg/tests/misc/multi_access.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/multi_access.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +/* run.config +STDOPT: +"-unspecified-access" +/ +struct S { int a; int b; }; + +int main () { + struct S s; + s.a = 0; + s.b = 1; + s.a = s.b = 2; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/nested_struct_init.i frama-c-20111001+nitrogen+dfsg/tests/misc/nested_struct_init.i --- frama-c-20110201+carbon+dfsg/tests/misc/nested_struct_init.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/nested_struct_init.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,57 @@ +typedef signed char int8_t; +typedef short int int16_t; +typedef int int32_t; +typedef long long int64_t; + +typedef unsigned char uint8_t; +typedef unsigned short int uint16_t; +typedef unsigned int uint32_t; + +struct S0 { + int8_t f0; + int16_t f1; + int64_t f2; + uint16_t f3; + int8_t f4; + int32_t f5; + int16_t f6; + int32_t f7; + int16_t f8; +}; + +struct S2 { + int8_t f0; + const int16_t f1; + int16_t f2; + int32_t f3; + uint8_t f4; + struct S0 f5; + int64_t f6; + int8_t f7; + int16_t f8; +}; + +struct S1 { + int32_t f0; + uint8_t f1; +}; + +struct S3 { + struct S2 f0; + const uint32_t f1; + const uint32_t f2; + int64_t f3; + struct S0 f4; + const struct S1 f5; + int8_t f6; + const int8_t f7; +}; + + +struct S0 g_3 = {-1L,0x4B54L,6L,7L,0xFFL,1L,-10L,0x67457993L,0x3C7DL}; +struct S3 g_8 = {{0xD5L,-10L,0L,0x900B0881L,0xDAL,{0xDBL,0x846BL,1L,-7L,0xF3L,0xFC0336AEL,6L,0x52E4A6B2L,0x4EB0L},0x117216709E149CFFLL,0x9CL,-1L},0x1636717BL,-4L,4L,{0xE3L,0xECDCL,0xF1FA6F63EEDA781BLL,0xF7A0L,0x7CL,0L,0xA77DL,0x7FC7DF39L,0x3C5AL},{0xA104ACD6L,0xA8L},0xADL,8L}; + +main(){ + Frama_C_dump_each(); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/non_iso_initializer.i frama-c-20111001+nitrogen+dfsg/tests/misc/non_iso_initializer.i --- frama-c-20110201+carbon+dfsg/tests/misc/non_iso_initializer.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/non_iso_initializer.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,7 @@ +int G0 = 42; +int G1 = G0>>1; +int G2 = G0 ^ G1 ; +int G3 = -1; +void main (void) { + G3=G0+G2; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/noreturn.i frama-c-20111001+nitrogen+dfsg/tests/misc/noreturn.i --- frama-c-20110201+carbon+dfsg/tests/misc/noreturn.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/noreturn.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,37 @@ +void stop(void) attribute ((noreturn)) ; + +int haltme(void) attribute ((noreturn)) ; + + +void never_ends(void) attribute ((noreturn)) +{ while(1) ; + return; +}; + +void should_never_end(int c) attribute ((noreturn)) +{ + if (c) while(1) ;} ; + +void warn_never_ends(void) +{ while(1) ;} ; + +void warn_may_never_end(int c) +{ + if (c) while(1) ;} ; + +static volatile int v=55,w=66; +int main(int c) { + int x=0; + + if (v) warn_may_never_end (v); + if (v) warn_may_never_end (1); + if (v) warn_never_ends (); + if (v) stop(); + if (v) x = haltme (); + if (v) never_ends (); + if (v) should_never_end (v); + if (v) should_never_end (1); + + return x; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/not.i frama-c-20111001+nitrogen+dfsg/tests/misc/not.i --- frama-c-20110201+carbon+dfsg/tests/misc/not.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/not.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,7 @@ +int x; +void main() { + + volatile int loc=0; + x = loc?!(0):0; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/null_lt_valid.i frama-c-20111001+nitrogen+dfsg/tests/misc/null_lt_valid.i --- frama-c-20110201+carbon+dfsg/tests/misc/null_lt_valid.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/null_lt_valid.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,38 @@ +int t[23]; +int p, q, r; + +void f(void){ + if (p < t) + p = 1; +} + +void g(void){ + int q1, q2; + if (q < t+22) + q1 = q; + else + q2 = q; +} + +void h(void){ + int r1, r2; + if (r < t+22) + r1 = r; + else + r2 = r; +} + +main(int c){ + if (c&32) + f(); + q = (c&64) ? t+(c&15) : p; + if (c&128) + g(); + r = (c&256) ? t+(c&31) : p; + if (c&512) + h(); + t[0] = (p < t); + t[1] = (q < t + 22); + t[2] = (r < t + 22); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/obfuscate.i frama-c-20111001+nitrogen+dfsg/tests/misc/obfuscate.i --- frama-c-20110201+carbon+dfsg/tests/misc/obfuscate.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/obfuscate.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,30 @@ +/ run.config + OPT: -obfuscate +/ + +int my_var = 0; + +/@ global invariant I: my_var >= 0; / + +enum my_enum { + first, second, third = 4 +}; + +/@ requires my_var > 0; + ensures my_var > \old(my_var); +/ +int my_func () { + + enum my_enum x = first; + /@ assert my_var >= first; / + my_var++; + return my_var + x; + +} + +/@ requires \valid(p); + ensures p == 0; +/ +void f(int* p); + +int main(intp) { f(p); } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/offset_neg.i frama-c-20111001+nitrogen+dfsg/tests/misc/offset_neg.i --- frama-c-20110201+carbon+dfsg/tests/misc/offset_neg.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/offset_neg.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,4 @@ +int G[5]; +int main () { + G[-1] = 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/offset_top.i frama-c-20111001+nitrogen+dfsg/tests/misc/offset_top.i --- frama-c-20110201+carbon+dfsg/tests/misc/offset_top.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/offset_top.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +/ run.config + OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0-0xFF -journal-disable +/ + +int T = (int)0; +int TAB[10]; + +void main() { + int i; + i = &TAB[T]; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/origin.i frama-c-20111001+nitrogen+dfsg/tests/misc/origin.i --- frama-c-20110201+carbon+dfsg/tests/misc/origin.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/origin.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,130 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -out -deps -main main -journal-disable + OPT: -memory-footprint 1 -val -out -deps -main origin -journal-disable + + +/ + +int a, b, aa2, p, pa1, pa2, qa2, pa3, q; + +int t[12], tt[10], ta1[10], ta2[10], ta3[10], tta2[10]; + +void origin_arithmetic_1(void) { + pa1 = (int)(-(int)ta1); + *pa1 = 0; +} +/************/ +void origin_arithmetic_2(int c1) { + pa2 = (int)(-(int)ta2); + qa2 = c1 ? pa2 : (int)(-(int)tta2); + *qa2 = &aa2; +} +/************/ +void origin_arithmetic_3(void) { + pa3 = (int)(-(int)ta3); + pa3 = 3; +} + + +int g(void); +int gp(void); + +int l1, l2, l3, pl; + +void origin_leaf_1 () { + l1 = g(); +} + +int * Tm1[2] ={&a, &b}; +int * Tm2[2] ={&a, &b}; +int * Tm3[2] ={&a, &b}; +int * Tm4[2] ={&a, &b}; +int pm1, pm2, qm2; + +void origin_misalign_1(void) { + pm1 = (int**)(2 + (char ) Tm1); + pm1 = 0; +} + +void origin_misalign_2(void) { + pm2 = *(int**)(2 + (char ) Tm2); + qm2 = pm2+1; + qm2 = (int)&a; +} + +int pun, pun2, qun2; + +void origin_uninitialized_1(int c1) { + int i, pi ; + if (c1) + pi = &a ; + pun = pi; +} + +void origin_uninitialized_2(int c1, int c2) { + int i, * pi ; + if (c1) + pi = &a ; + pun2 = pi; + + if (c2) + qun2 = pun2 + i; +} + +volatile int random; +int esc1, esc2, esc3, esc4, esc5; +void local_escape_1(int arg) +{ + int local1, local2; + esc1 = (int) &arg; + esc2 = (int) &local1; + esc3 = - (int) &arg; + esc4 = random ? esc2 : 12; + local2 = (int) &local1; + esc5 = (int) &esc1; +} + + +void main(int c1, int c2) +{ + origin_arithmetic_1(); + origin_arithmetic_2(c1); + origin_arithmetic_3(); + origin_leaf_1 (); + l2 = l1; + l2 += g(); + pl = gp(); + l3 = pl; + origin_misalign_1(); + origin_misalign_2(); + p = (int**)(2 + (char ) Tm3); + q = c1 ? p : (int**)(3 + (char *) Tm4); + origin_uninitialized_1(c1); + origin_uninitialized_2(c1, c2); + local_escape_1(12); +} + + +/************************************/ +int x, y; +struct st { + char c; + short i; + int p, t[2]; +} v = { 1, 2, &x, &y}; + +struct st origin (int c0) { + struct st r; + int q1, q2; + + r.c = f() ; + r.i = c0 ; + r.p = (int ) (&v.c + 3); + q1 = *(int**)(2 + (char ) v.t); + q2 = c0 ? q1 : (int**)(3 + (char ) v.t); + r.t[0] = q2 ; + r.t[1] = (int )(- (int)&x) ; + return r; +} +/************************************/ diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/orig_name.i frama-c-20111001+nitrogen+dfsg/tests/misc/orig_name.i --- frama-c-20110201+carbon+dfsg/tests/misc/orig_name.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/orig_name.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/* run.config + CMD: bin/toplevel.byte + OPT: -orig-name -journal-disable -print +/ + +int x = 1; + +int f(int x) { + int y = 0; + if (x == 0) { + int x = 3; + y = x++; + } + y += x; + return y; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/output_leafs.i frama-c-20111001+nitrogen+dfsg/tests/misc/output_leafs.i --- frama-c-20110201+carbon+dfsg/tests/misc/output_leafs.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/output_leafs.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,48 @@ + +int H,G,K,L,M,N,P; + +/@ assigns G \from G,H; + @ assigns H \from P; + @ assigns x \from \empty; +/ +void crypt(intx); + +void main1(int y) +{ + H = &K; + crypt(&L); + +} + +int a, b, c, d; + +//@ assigns u \from v; +void g(int v, const int u); + +void g1() { + g(&a,&b); +} + +void g2() { + g(&c,&d); +} + +void main2 () { + g1(); + g2(); +} + + +void f(int* x); + +int main3 () { + int x = 0; + f(&x); + return x; +} + +void main(int y) { + main1(y); + main2(); + main3(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/overflow_cast_float_int.i frama-c-20111001+nitrogen+dfsg/tests/misc/overflow_cast_float_int.i --- frama-c-20110201+carbon+dfsg/tests/misc/overflow_cast_float_int.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/overflow_cast_float_int.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ + +int main() +{ +float vf1; +signed int e; +unsigned int d; +d = 0x7FFFFFFFll; +vf1 = d * 1.0; +e = (int)vf1 + 0; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/overflow.i frama-c-20111001+nitrogen+dfsg/tests/misc/overflow.i --- frama-c-20110201+carbon+dfsg/tests/misc/overflow.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/overflow.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,34 @@ +/* run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -val-signed-overflow-alarms + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable +/ +extern int printf (const char restrict __format, ...); +/* L'analyseur d�borde et dit i=-1 / +int main (int c) { + unsigned long long i = 0xFFFFFFFFFFFFFFFFULL; + unsigned long j = 0xFFFFFFFFUL; + + long long is = 0xFFFFFFFFFFFFFFFFULL; + long js = 0xFFFFFFFFUL; + long minjs = - (j/2) -1 ; + long maxjs = j/2 ; + + unsigned long long i1 = i+1; + unsigned long j1 = j+1; + + int y = c?1:100000; + int x = (60000 y ) / 100000; + int z = y * 1000 * 1000; + int t = (-y) * 10000000; +/* + printf("unsigned long long:%llu (+1:%llu)\nunsigned long:%lu (+1:%lu)\n" + ,i,i1,j,j1); + printf("signed long long:%lld (+1:%lld)\nlong:%ld (+1:%ld)\n" + ,is,is+1,js,js+1); + printf("min signed long:%ld (-1:%ld)\n" + ,minjs,minjs-1L); +/ + if (-c) {} + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/paths.i frama-c-20111001+nitrogen+dfsg/tests/misc/paths.i --- frama-c-20110201+carbon+dfsg/tests/misc/paths.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/paths.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,53 @@ +/ run.config + OPT: -memory-footprint 1 -experimental-path-deps -deps -journal-disable +/ +int a,b,c,d,e,i,d1,d2,d3,d4,X1,X2,X3,X4,X5,X; + +void f1(void) +{ + X = X1; + if (d1) X = X4; +} + +void f2(void) +{ + X = X2; +} + +void f3(void) +{ + X = X3; +} + +int f(int fx, int fy, int fz) +{ + d2 = fx; + if (fy) i++; + return d3; +} + +void (t[3])(void)={f1, f2, f3}; + +/@ assigns \result \from x ; / +int unknownfun(int x); + +int main(int r,int s,int u,int v,int w,int x,int y,int z,int ww){ + d1 = x; + c = u?a:b; + d = b + v; + d4 = unknownfun(ww); + if (d4) + i++; + r++; + if (d) + a=1; + (t[w])(); + if (X) + i++; + d3 = z; + if (f(y,s,r)) + i++; + if (d2) + i++; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pb.i frama-c-20111001+nitrogen+dfsg/tests/misc/pb.i --- frama-c-20110201+carbon+dfsg/tests/misc/pb.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pb.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,2 @@ + +void main () { f() ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer2.i frama-c-20111001+nitrogen+dfsg/tests/misc/pointer2.i --- frama-c-20110201+carbon+dfsg/tests/misc/pointer2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main g -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main h -journal-disable +/ +int f (int r) { + return r; +} + +int p, q; +int x,y,z; + +void g() { + p = f(&x); +} + +void h() { + q = f(&y); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer3.i frama-c-20111001+nitrogen+dfsg/tests/misc/pointer3.i --- frama-c-20110201+carbon+dfsg/tests/misc/pointer3.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer3.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,15 @@ +int x,y,c; +int p,q; + +int f(int * x) { + c=2; + return x; +} + +void main() { + c=1; + p = f(&x); + q = f(&y); + p = c; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer4.i frama-c-20111001+nitrogen+dfsg/tests/misc/pointer4.i --- frama-c-20110201+carbon+dfsg/tests/misc/pointer4.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer4.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -absolute-valid-range 0-0x7 -journal-disable +/ +unsigned short d,e[10]={0},c = 0; + +void main(void) { + + ((int)0x0)[1] = 1; + ((int)0x0)[0] = 2; + d = 1; + for (c=0; c<=10; c++){ + e[0] = 1; + d=0; + ((int)0x0)[c] = 0;} +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer_arg.i frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_arg.i --- frama-c-20110201+carbon+dfsg/tests/misc/pointer_arg.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_arg.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +int main(chararg,int argc,char argv[2]) { + arg[0] = 0; + arg[1] = 1; + arg[2] = 1; + if (!argc) arg[1000]=1000; + arg[argc] = 4; + + argv[1] = "5069"; + argv[0] = "5069"; + + argv[0][0] = '0'; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer_comp.c frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_comp.c --- frama-c-20110201+carbon+dfsg/tests/misc/pointer_comp.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_comp.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,48 @@ +extern int v; + +char str1[] = "absd"; +char str2[] = "abdd"; + +struct s { int x; }; +struct s s1; +struct s s2[8]; + +void f(void); +void g(void); + +void* NULL=0; + +void main () { + int i; + void (p)(void) = (v ? &f : &g); + // Valid + i = (&str1 == &str2); + i = (&s1 == NULL); + i = (&s1+1 == NULL); + i = (&s2[2] == &s2[4]); + i = (&s2[8] == NULL); + i = (&f == NULL); + i = (&s1 == &s2); + i = (&f == &g); + i = (p == NULL); + + // Valid + i = (&s2[2] < &s2[4]); + + // Invalid + i = (&s2[9] == NULL); + i = (&s2[9] == &s2[9]); + + // Invalid + i = (&str1 < &str2); + i = (&s1 < &s2); + i = (&f < &g); + + // ? + i = (&s1 > NULL); + i = (&s1+1 > NULL); + i = (&s2[8] > NULL); + i = (&f > NULL); + i = (p > NULL); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer.i frama-c-20111001+nitrogen+dfsg/tests/misc/pointer.i --- frama-c-20110201+carbon+dfsg/tests/misc/pointer.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,42 @@ +int x,y,c,p,q,T[10]; + +void g() { + p = (int)(void)&y; + p = c; +} + +void f1() { + x = y; + q= &x; + if (c) p = &x; + p = &c; +// p = &T[c]; + p = q; +} + +/@ ensures x > 0; / +void h() { + p = &x; + c = p; + p = y; +} + + +void l(int y) { + y = x; +} +void k(int x) { + l(x); +} + +int cc1, cc2;; + +void main(int en) { + c=17; + x=19; + k(&c); + k(&x); + cc1 = cc2 = 99; + if (en & 1) cc1 = T-1 <= T; + if (en & 2) cc2 = T <= T+12; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer_int_cast.i frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_int_cast.i --- frama-c-20110201+carbon+dfsg/tests/misc/pointer_int_cast.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_int_cast.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,12 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main g -journal-disable +/ +int q; +int x,y=0; +void g(){ + int i = 0; + if (y==0) i = &y; + q = (int)i; + q = x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pointer_loop.i frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_loop.i --- frama-c-20110201+carbon+dfsg/tests/misc/pointer_loop.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pointer_loop.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,53 @@ +/* run.config + OPT: -memory-footprint 1 -val -out -input -deps -journal-disable + / +int base0=7; +int base1=1; +int base2=2; +int base_p[2]={&base1,&base2}; +int ioCtrl_p; +void main () +{ short int i; + int uiNmbrOfElements = 2; + + for (i = 0; i < uiNmbrOfElements; i++) + { + ioCtrl_p = base_p[i]; + ioCtrl_p = 3+i; + } +} + + +struct auIoCtrl; +typedef struct auIoSlot { + int uiNmbrOfElements; + struct auIoCtrl const ioCtrl_p; +} auIoSlot_t; +typedef struct auIoCtrl { + const auIoSlot_t slot_p; + int inDriverStatus; +} auIoCtrl_t; + +auIoCtrl_t i_auIoCtrl[2]; +static auIoCtrl_t const auIoCtrl_p[2] = { + &i_auIoCtrl[0], + &i_auIoCtrl[1] +}; +const auIoSlot_t i_auIoSlot[2] = { + { 2, &auIoCtrl_p[0]}, + { 0, (void ) 0} +}; + +void f(void) +{ + int i; + enum counter j; // specific test for pointer_loop.c:42: error: storage size of 'j' isn't known + i=0; + (i_auIoSlot[i].ioCtrl_p[0])->inDriverStatus = 0; + (i_auIoSlot[i].ioCtrl_p[1])->inDriverStatus = 0; + for(j = 0; j < 2; j++) { + (i_auIoSlot[i].ioCtrl_p[j])->inDriverStatus = 1; + + } + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/postcondition.i frama-c-20111001+nitrogen+dfsg/tests/misc/postcondition.i --- frama-c-20110201+carbon+dfsg/tests/misc/postcondition.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/postcondition.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,95 @@ +int G; +int A,B,C,D,E,EX,X; + +//@ ensures -100 <= \result <= 100 ; +int u(void); + +//@ ensures min <= \result <= max ; +int cap(int min, int max); + +/@ + @ requires 0<=cmd<5; + @ ensures 0<=\result<300; + @/ +int get_index(int / in / cmd) +{ + int ret=0; + Frama_C_show_each_cmd(cmd); + while (ret <= 100cmd) + { + if (u()) return ret; + ret++; + } + return ret; +} + +/@ ensures EX <= cmd ; / +int bound(int cmd) +{ + cmd = 2; /* vicious / +} + +//@ ensures G == 6; +void t0 () { + G = 6; +} + +//@ ensures G == 7; +void t1 () { + G = 6; +} + +int p; + +//@ ensures p == 6 && G == p && G == 6; +void t2 () { + p = &G; + p = 6; +} + + +typedef struct { + int a; + int b; + int c; +} st; + +st TAB[10]; + +//@ ensures TAB->a == 12; +void t3 () { + TAB->a = 12; +} + +//@ ensures x<=y; +void t4(int x, int y) { + x++; y--; +} + +/@ ensures x == \old(x); + ensures \result > \old(X); / +int t5(int x) { + x = X; + return ++x; +} + +/@ ensures \result == 0; + @ ensures \false; + @ / +int f(void) { return 0; } + +void main(){ + B=get_index(1); + EX = u(); / it is incorrect to affirm that EX<=2 after this line / + bound(8); + C=get_index(u()?4:6); + D = u(); + E = cap(20, 80); + if (u()) t0(); + if (u()) t1(); + if (u()) t2(); + if (u()) t3(); + t4(3,4); + if (u()) { X = 8; t5(2); } + if (B) f(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/ptr_relation.i frama-c-20111001+nitrogen+dfsg/tests/misc/ptr_relation.i --- frama-c-20110201+carbon+dfsg/tests/misc/ptr_relation.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/ptr_relation.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,40 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main2 -journal-disable +/ +long i,j,x,k,l,m,n,d,a,b; +long ptr; + +//----------------------------------------- +void main(int c) { + a = 333; + ptr = c ? &a : &b ; + ptr = 77; + i=ptr+1-1; + return; +// needs relations to be accurate +} +//----------------------------------------- +void main1(int c) { + i = c?3:4; + + x = i; + j = x - i; +} +//----------------------------------------- +// Just a test for dependencies +void f2 (int arg) { + b = arg + l; + a = arg + m ; +} +void g2 (int arg) { + a = arg + n ; +} +void (tab_ptr_fct2[2])(int) = { &f2, &g2}; +void main2(int c,int arg) { + j = c?0:1; + (tab_ptr_fct2[j])(arg); // Dependency of j are taken into account. +} +//----------------------------------------- diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/pure_exp.i frama-c-20111001+nitrogen+dfsg/tests/misc/pure_exp.i --- frama-c-20110201+carbon+dfsg/tests/misc/pure_exp.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/pure_exp.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +/* bug #5877 on gforge / + + int t = 0; + + int main(void) + { + /* should lead to an alarm. / + t == 42; + + return 0; + } diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/qualified_arrays.i frama-c-20111001+nitrogen+dfsg/tests/misc/qualified_arrays.i --- frama-c-20110201+carbon+dfsg/tests/misc/qualified_arrays.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/qualified_arrays.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +typedef unsigned int TAB120[ 120 ] ; + +extern volatile TAB120 volatile_tab_120_2[ 2 ]; + +volatile unsigned int* const p_first_volatile = &volatile_tab_120_2[0][0] ; + +struct foo { int x; }; + +volatile struct foo f = { 1 }; + +volatile int* x = &f.x; + +/@ requires p_first_volatile == &volatile_tab_120_2[0][0] ; + requires x == &f.x; + / +int main(void) { + p_first_volatile = &volatile_tab_120_2[1][112] ; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/raz.i frama-c-20111001+nitrogen+dfsg/tests/misc/raz.i --- frama-c-20110201+carbon+dfsg/tests/misc/raz.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/raz.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +volatile int h; + +int main() { + int n = h?0:10; + int r = 0, i; + // @ ensures i==n + // @ invariant 0 <= i && i <= n + for (i=0; i<n ; i++) + r = 1; + return r; +} +/* +void main0() { + int n = 10; + int r = 1; + //@ ensures r == 0 + if (r) r = 0; + //@ ensures r == 0 + for (int i=11; i<5 ; i++) + r = 0; +} +/ diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/reading_null.i frama-c-20111001+nitrogen+dfsg/tests/misc/reading_null.i --- frama-c-20110201+carbon+dfsg/tests/misc/reading_null.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/reading_null.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,56 @@ +/ run.config + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main main -journal-disable +/ + +unsigned short AutoTest[1000]={0}; + +int X; +int T[]={&X,0,}; + + +int X1; +int X2; +int X3; +int X4,X5,X6,X7,X8,X9; + +void main(int c){ + + + int count = 0; + +// int p=T[c]; +// X = p; + + while(count<10) { + CEA_F(X,count); + switch (count) { + case 0: X = X1; + break; + case 1: X = X2; + break; + case 2: X = X3; + break; + case 3: X = X4; + break; + case 4: X = X5; + break; + case 5: X = X6; + break; + case 6: X = X7; + break; + case 7: X = X8; + break; + case 8: X = X9; + break; + } + count++; + } +} + +void main1(int c){ + + int X1; + int* X2; + X1 = X2; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/rec.i frama-c-20111001+nitrogen+dfsg/tests/misc/rec.i --- frama-c-20110201+carbon+dfsg/tests/misc/rec.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/rec.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,5 @@ +void main() { + int X=0; + if (X) main(); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/recursion2.i frama-c-20111001+nitrogen+dfsg/tests/misc/recursion2.i --- frama-c-20110201+carbon+dfsg/tests/misc/recursion2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/recursion2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,23 @@ +/run.config + OPT: -journal-disable -input -val + / +int x, y; + +void h2 (int); +void h1 (int); + +void h1 (int i) { + int r = x; + if (i) + h2 (i); +} +void h2 (int i) { + int r = y; + if (!i) + h1 (i); +} + +void main() { + h2(0); + h1(1); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/recursion.i frama-c-20111001+nitrogen+dfsg/tests/misc/recursion.i --- frama-c-20110201+carbon+dfsg/tests/misc/recursion.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/recursion.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +/run.config + OPT: -lib-entry -main main -val -journal-disable + OPT: -lib-entry -main main -val -val-ignore-recursive-calls -journal-disable + / +int G; + +int f() { + if (G) f(); + return 5; +} +void main() { + G = f(); + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/reduce_valid.i frama-c-20111001+nitrogen+dfsg/tests/misc/reduce_valid.i --- frama-c-20110201+carbon+dfsg/tests/misc/reduce_valid.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/reduce_valid.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,26 @@ +int t[2]; +int p,q,r, A, offs; + +void main(int c, int d, int e, int f, int g) +{ + + + p = c ? t : (void)0; + p = 2; + p[1] = 3; + p = 4; + + q = (void)0; + if (d) + { + CEA_ici(0); + q = 3; + q = 4; + CEA_la(0); + } + + r = e ? (f ? t : t+1) : (void)0; + offs = g ? 1 : 2; + A = r[offs]; + Frama_C_show_each_r(r); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/relation_reduction.i frama-c-20111001+nitrogen+dfsg/tests/misc/relation_reduction.i --- frama-c-20110201+carbon+dfsg/tests/misc/relation_reduction.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/relation_reduction.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +int y,t; +int R1,R2,R3,R4; +int c; +int tab[9] = { 101, 102, 103, 104, 105, 106, 103, 102, 101 }; + +void main(int x) +{ + y = x; + t = y + 10; + if (x == 2) + { + R1 = y; + R2 = t; + } + + if (t == 17) + R3 = x; + + if (x>=0 && x<=5) + if (tab[y] == 103) + R4 = x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/relations_difficult.i frama-c-20111001+nitrogen+dfsg/tests/misc/relations_difficult.i --- frama-c-20110201+carbon+dfsg/tests/misc/relations_difficult.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/relations_difficult.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,17 @@ +int x,y,p; +int A,B,C,Z; + +int main(int c) +{ + x = 0; + y = 1; + p = c ? &x : &y; + p = 2; + x = 3; + A = p; / optimal : {2,3} ; sans relations : {1,2,3} / + x = 4; + B = (p) + Z; /* optimal : {2,4} ; sans relations : {1,2,4}; + avec relations actuelles : {2,3,4} / + C = p; /* meme chose avec copy-paste / + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/relation_shift.i frama-c-20111001+nitrogen+dfsg/tests/misc/relation_shift.i --- frama-c-20110201+carbon+dfsg/tests/misc/relation_shift.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/relation_shift.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,28 @@ +int r1,r2,r3,r4; + +void main (int x,int y,int z,int t,int p,int q[2]) { + x = y ; + x++; + y--; + p=(int)(&p); + p++; + z = x; + t=5; + z+=t; + q=3; + q++; + + r1 = x-y; + r2 = z-y; + r3 = (q-1); + r4 = q; + CEA_DUMP(); +} + +void main1 (int x,int y,int z,int t,int p,int q) { + q = 3; + q++; + r3 = (q-1); + r4 = q; + CEA_DUMP(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/relations.i frama-c-20111001+nitrogen+dfsg/tests/misc/relations.i --- frama-c-20110201+carbon+dfsg/tests/misc/relations.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/relations.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,63 @@ + +int t[3]={1,2,3}; +int p,x; +int u[20]; +int R1,R2,R3,R4,R5,R6,R7,A7,R8,A8; +int S1,S2,S3,S4,S5,S6,S7,B7,S8,B8; + +typedef struct { +int L0; +int L1; +int T13; +int T; +int L8; +} Cs; + +void main(int c,char d,char e, int f, int g, int h, int i, Cs pCs) +{ + u[0] = g; + p=&t[1]; + p=4; + if (c) c=0; + t[0]=t[1]; + x=(p-1); + e=d; + e=d-e +1; + if (d) ((char)&f)=e; else f = x; + + u[1] = u[0]; + if (u[1] == 3) + { + R1 = u[0]; + R2 = g; + } + + u[5] = u[0] + 1; + if (u[5] == 3) + { + R3 = u[0]; + R4 = g; + } + R5 = u[5] - u[0]; + + u[10] = h; + u[11] = i; + if (u[10] == u[11]) + R6 = u[10] - u[11]; + + A7 = u[1] - u[0]; + if (u[1] == u[0]) + R7 = 1; + + A8 = u[5] - u[1]; + if (u[5] == u[1]) + R8 = 1; + + pCs->T13 = pCs->L0 || pCs->L1; + pCs->T = pCs->T13; + pCs->L8 = pCs->L0 || pCs->T13; + + S1 = pCs->T - pCs->T13; + if ( pCs->T == pCs->T13) + S2 = 1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/resolve.i frama-c-20111001+nitrogen+dfsg/tests/misc/resolve.i --- frama-c-20110201+carbon+dfsg/tests/misc/resolve.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/resolve.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ + + +int f( int , int); + +int f(int , int ); + +int f(int , int ); + + +//@ assigns \result; +int main(void) { + return f(0,1); +} + +//@ assigns \result; +int main(void); diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/return.i frama-c-20111001+nitrogen+dfsg/tests/misc/return.i --- frama-c-20110201+carbon+dfsg/tests/misc/return.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/return.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +int G,H; + +int f(int x) { + return (x+G); +} + +int g(int x) { + return 1; +} + +int h(int x) { + return x; +} + +void main (int c) { + + if (c) + H = f(H); + else G = f(G); + + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/save_comments.i frama-c-20111001+nitrogen+dfsg/tests/misc/save_comments.i --- frama-c-20110201+carbon+dfsg/tests/misc/save_comments.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/save_comments.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +/ run.config + OPT: -load-script tests/misc/save_comments.ml -keep-comments +/ + + +int f() { + int x = 0; + / Hello, I'm the f function / + return x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/save_comments.ml frama-c-20111001+nitrogen+dfsg/tests/misc/save_comments.ml --- frama-c-20110201+carbon+dfsg/tests/misc/save_comments.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/save_comments.ml 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,40 @@ +open Cil_types +open Cil + +let find_comment () = + let kf = Globals.Functions.find_by_name "f" in + let loc1 = Kernel_function.get_location kf in + let loc2 = Cil_datatype.Stmt.loc (Kernel_function.find_return kf) in + let zone = (fst loc1, snd loc2) in + Format.printf + "@[In project %s, searching for comments between %a and %a:@\n%a\ + @\nEnd of comments@." + (Project.get_name (Project.current())) + Cil.d_loc loc1 + Cil.d_loc loc2 + (Pretty_utils.pp_list ~sep:"@\n" Format.pp_print_string) + (Cabshelper.Comments.get zone) + +let run () = + let ast = Ast.get () in + let vis = object + inherit Visitor.frama_c_inplace + method vglob_aux g = match g with GText s -> Format.printf "got global comment %s@." s; SkipChildren | _ -> DoChildren + end + in + ignore (Visitor.visitFramacFile vis ast); + let fmt = Format.std_formatter in + Format.printf "Printing default project first time:@."; + File.pretty_ast ~fmt (); + Format.printf "Printing default project second time:@."; + File.pretty_ast ~fmt (); + let file = Extlib.temp_file_cleanup_at_exit "save_comments_test" ".sav" in + let name = "saved_project" in + find_comment (); + Project.save file; + let prj = Project.load ~name file in + Project.on prj find_comment (); + Format.printf "Printing saved project:@."; + File.pretty_ast ~prj ~fmt () + +let () = Db.Main.extend run diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/semaphore.i frama-c-20111001+nitrogen+dfsg/tests/misc/semaphore.i --- frama-c-20110201+carbon+dfsg/tests/misc/semaphore.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/semaphore.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,52 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main g -journal-disable +/ +int Sa; +int Sb; + + +void f (void) +{ + int c = 12; + + if (c) + P (Sa); + + P (Sa); + P (Sb); + + V (Sa); + V (Sb); +} + +void g (void) +{ + int c = -25; + + + while (c--) + while (c) + { + V (Sa); + c++; + } + P (Sb); + P (Sa); + + V (Sa); + V (Sb); + + f(); +} + +/ +void creation_tache( void (f)(void)) { + (f)(); +}; +void main (void) +{ + Screation_tache (&f); + Screation_tache (&g); +} +/ diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/sep.i frama-c-20111001+nitrogen+dfsg/tests/misc/sep.i --- frama-c-20110201+carbon+dfsg/tests/misc/sep.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/sep.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,45 @@ +/ run.config + OPT: -memory-footprint 1 -val -slevel 10 -lib-entry -main f1 -separate-n 0 -separate-of 3 + OPT: -memory-footprint 1 -val -slevel 10 -lib-entry -main f1 -separate-n 1 -separate-of 3 + OPT: -memory-footprint 1 -val -slevel 10 -lib-entry -main f1 -separate-n 2 -separate-of 3 + OPT: -memory-footprint 1 -val -slevel 10 -lib-entry -main f1 -separate-n 3 -separate-of 3 +/ + +int index; +int tab[5]; + +//@ ensures \result==0 || \result==-1 || \result==1 ; +extern int init2(void); + +int init1(void) +{ + int res; + + res = init2(); + + if (res == 0) + { + index=0; + } + else + { + if (res == 1) + { + res = 0; + index = 0; + } + } + + return res; +} + +//@ requires 0<=n<5; +int f1(int n) +{ + int res; + + res = init1(); + + if (res == 0) + return tab[index+n]; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/serv.i frama-c-20111001+nitrogen+dfsg/tests/misc/serv.i --- frama-c-20110201+carbon+dfsg/tests/misc/serv.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/serv.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +/ run.config + DONTRUN: cannot find entry point: main +/ + +void f1() { + f3(); +} + +void f2() { + f4(); +} + +void f3() { + f4 (); +} + +void f4() { + f3 (); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/shift.i frama-c-20111001+nitrogen+dfsg/tests/misc/shift.i --- frama-c-20110201+carbon+dfsg/tests/misc/shift.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/shift.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,33 @@ +int a,b,d,e,f,g,h; +unsigned int ua,ub,uc,ud,ue,uf; + +int main(int c, int z, int zz) { + a=5024; + d = 255; + f= -255; + if ((c<=3) && (c>=0)) { + c = 2c-1; + a = 157 << c; + d=1975; + d = d >> c; + f= -1975; + f = f >> c; + } + + if (z) z=1<<32; + if (zz) zz=1>>5555; + + if (c) { + b = 66; + b = b << b; + }; + + + ua = 5607; + ua >>= 2 ; + ub = (unsigned int)(-3000); + ub >>= 2; + printf("ua:%u\nub:%u\n",ua,ub); + + return b; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/simple_packed.c frama-c-20111001+nitrogen+dfsg/tests/misc/simple_packed.c --- frama-c-20110201+carbon+dfsg/tests/misc/simple_packed.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/simple_packed.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,21 @@ +struct my_unpacked_struct +{ + char c; + int i; +}; + +struct my_packed_struct +{ char c; + int i; + struct my_unpacked_struct s; +} attribute ((packed)); + +struct my_packed_struct f(struct my_packed_struct foo) { + struct my_packed_struct bar=foo; + return foo; +} + +struct my_packed_struct main(struct my_packed_struct foo) { + f(foo); + return foo; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/simple_path.i frama-c-20111001+nitrogen+dfsg/tests/misc/simple_path.i --- frama-c-20110201+carbon+dfsg/tests/misc/simple_path.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/simple_path.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +int G,H; +int p = &G; +int q = &H; + +void main(void) +{ + G = 4; + p = 3; + p = &H; + p = 5; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/simplify_cfg.i frama-c-20111001+nitrogen+dfsg/tests/misc/simplify_cfg.i --- frama-c-20110201+carbon+dfsg/tests/misc/simplify_cfg.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/simplify_cfg.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +/* run.config + OPT: -simplify-cfg -keep-switch -val -check -journal-disable + OPT: -simplify-cfg -val -check -journal-disable +/ + +int main(int x, int y) { + int z = 0; + char c = 'c'; + switch (x) { + case 0: z=(int)c; + default: z++; + } + return z; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/simp_switch.i frama-c-20111001+nitrogen+dfsg/tests/misc/simp_switch.i --- frama-c-20110201+carbon+dfsg/tests/misc/simp_switch.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/simp_switch.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,10 @@ +/ run.config + OPT: -check -simplify-cfg -print + / +void main() +{ + switch(0) { + case 0: + break; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/sizeof.i frama-c-20111001+nitrogen+dfsg/tests/misc/sizeof.i --- frama-c-20110201+carbon+dfsg/tests/misc/sizeof.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/sizeof.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +int sz_str,sz_typ,align_str,align_typ; + +void main() +{ + sz_str= sizeof("ONE"); + //@ assert sz_str == sizeof("ONE"); + align_str= __alignof("FOO"); + // assert align_str == __alignof("FOO"); + sz_typ= sizeof(char); + //@ assert sz_typ == sizeof(char); + align_typ= __alignof(char); + // assert align_typ == __alignof((char)); + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/slevelex.i frama-c-20111001+nitrogen+dfsg/tests/misc/slevelex.i --- frama-c-20110201+carbon+dfsg/tests/misc/slevelex.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/slevelex.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,90 @@ +/ run.config + STDOPT: +"-slevel 4 -slevel-function main:0 -slevel-function gu:20 -slevel-function ginc:20" +/ + +volatile int c; + +int f(void) +{ + int x, y; + if (c) + { + x = 1; + y = 1; + } + else + { + x = 2; + y = 2; + } + return xx - yy; +} + +void gu(int u) +{ + /@ assert + u == 1 || + u == 2 || u == 3 || + u == 4 || u == 5 || + u == 6 || u == 7 || + u == 8 || + u == 9 || u == 10 || + u == 11 || + u == 12 || u == 13 || + u == 14 || u == 15 || + u == 16 || u == 17 || + u == 18 || + u == 19 || u == 20 ; + / + + Frama_C_show_each_u(u); +} + +void ginc(int u) +{ + int inc; + inc = 4 u; + + /@ assert + inc == 4 || + inc == 8 || inc == 12 || + inc == 16 || inc == 20 || + inc == 24 || inc == 28 || + inc == 32 || + inc == 36 || + inc == 40 || inc == 44 || + inc == 48 || inc == 52 || + inc == 56 || inc == 60 || + inc == 64 || inc == 68 || + inc == 72 || inc == 76 || + inc == 80 ; + / + + Frama_C_show_each_inc(inc); +} + + +void main(int un) +{ + int x, y; + if (c) + { + x = 1; + y = 1; + } + else + { + x = 2; + y = 2; + } + //@ assert xx == yy ; + + Frama_C_show_each_xy(x,y); + x = f(); + //@ assert x == 0; + + if (un>=20) un = 20; + if (un<=1) un = 1; + gu(un); + ginc(un); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/small_conditionals.i frama-c-20111001+nitrogen+dfsg/tests/misc/small_conditionals.i --- frama-c-20110201+carbon+dfsg/tests/misc/small_conditionals.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/small_conditionals.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,6 @@ +char Y,Z,U ; +void main(char X) { + Y = X?:2; + + Z = U?3:4; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/sort4.i frama-c-20111001+nitrogen+dfsg/tests/misc/sort4.i --- frama-c-20110201+carbon+dfsg/tests/misc/sort4.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/sort4.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,74 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main sort4_1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main sort4_4 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -lib-entry -main sort4_3 -journal-disable +/ + +/ sort 4 integers / + +int a, b, c, d; + +void sort4_1() { + + int tmp; + if (a > b) { tmp = a; a = b; b = tmp; } + if (c > d) { tmp = c; c = d; d = tmp; } + if (a > c) { tmp = a; a = c; c = tmp; } + if (b > d) { tmp = b; b = d; d = tmp; } + if (b > c) { tmp = b; b = c; c = tmp; } + /@ assert a <= b <= c <= d; / +} + + + +/@ requires \valid_range(t,0,4); + ensures t[0] <= t[1] <= t[2] <= t[3]; / +void sort4_4(int t[4]) { + int tmp; + if (t[0] > t[1]) { tmp = t[0]; t[0] = t[1]; t[1] = tmp; } + if (t[2] > t[3]) { tmp = t[2]; t[2] = t[3]; t[3] = tmp; } + if (t[0] > t[2]) { tmp = t[0]; t[0] = t[2]; t[2] = tmp; } + if (t[1] > t[3]) { tmp = t[1]; t[1] = t[3]; t[3] = tmp; } + if (t[1] > t[2]) { tmp = t[1]; t[1] = t[2]; t[2] = tmp; } +} + + +/ commented because of memory explosion / +#if 0 +/@ requires \valid(a) && \valid(b) && \valid(c) && \valid(d) && + @ a != b && a != c && a != d && b != c && b != d && c != d; + @ ensures a <= b <= c <= d; / +void sort4_2(int a, int b, int c, int d) { + int tmp; + if (a > b) { tmp = a; a = b; b = tmp; } + if (c > d) { tmp = c; c = d; d = tmp; } + if (a > c) { tmp = a; a = c; c = tmp; } + if (b > d) { tmp = b; b = d; d = tmp; } + if (b > c) { tmp = b; b = c; c = tmp; } +} +#endif + + + +/@ predicate swap_ord(int a2,int b2,int a1,int b1) = + @ (a1 <= b1 ==> (a2 == a1 && b2 == b1)) && + @ (a1 > b1 ==> (a2 == b1 && b2 == a1)) ; + @/ + +/@ requires \valid(a) && \valid(b) && \valid(c) && \valid(d) && + @ a != b && a != c && a != d && b != c && b != d && c != d; + @ ensures a <= b <= c <= d; / +void sort4_3(int a, int b, int c, int d) { + int tmp; + // assigns a,b,tmp; ensures swap_ord( a,b,\old( a),\old( b)); + if (a > b) { tmp = a; a = b; b = tmp; } + // assigns c,d,tmp; ensures swap_ord( c,d,\old( c),\old( d)); + if (c > d) { tmp = c; c = d; d = tmp; } + // assigns a,c,tmp; ensures swap_ord( a,c,\old( a),\old( c)); + if (a > c) { tmp = a; a = c; c = tmp; } + // assigns b,d,tmp; ensures swap_ord( b,d,\old( b),\old( d)); + if (b > d) { tmp = b; b = d; d = tmp; } + // assigns b,c,tmp; ensures swap_ord( b,c,\old( b),\old( c)); + if (b > c) { tmp = b; b = c; c = tmp; } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/statement_contract.i frama-c-20111001+nitrogen+dfsg/tests/misc/statement_contract.i --- frama-c-20110201+carbon+dfsg/tests/misc/statement_contract.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/statement_contract.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +int A; + +/@ behavior test: + assumes A == 0; + ensures \result == 3; + behavior test2: // invalid + assumes \false; + ensures \result == 0; +/ +int main() +{ +int d; +d=4; +/@ + requires d>0; assigns d; ensures d==3; + behavior foo: + assumes d == 0; + ensures d == 42; +/ +d=3; +return d; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/static.i frama-c-20111001+nitrogen+dfsg/tests/misc/static.i --- frama-c-20110201+carbon+dfsg/tests/misc/static.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/static.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,32 @@ +int f (void) +{ + static int x; + return &x; +} + +int GLOB={{{{0}}}}; +char T[10]={0}; +int IT[10]={0}; +int G; +char H; +int R; + +int volatile p; +int a[2]={77}; +int Rv=99; + +int main() { + (f()) = 3; + R = f(); + GLOB = sizeof main (); + G = ((int)&(T[1])); + H = ((char)&(IT[9])); + + + p = &a; + Rv = p; + + return T[0]; + +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/strange.i frama-c-20111001+nitrogen+dfsg/tests/misc/strange.i --- frama-c-20110201+carbon+dfsg/tests/misc/strange.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/strange.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,18 @@ +int GG; + +int f (void) +{ int G; + G = 2; + GG = 3; + return 1; } + + +int main (void) +{ int lm = 77; + + int res_f = f(); + GG = lm; + + return 0; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/strings_cond.i frama-c-20111001+nitrogen+dfsg/tests/misc/strings_cond.i --- frama-c-20110201+carbon+dfsg/tests/misc/strings_cond.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/strings_cond.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ + +void foo(char s) { + Frama_C_dump_each(); + while(s) { Frama_C_show_each_s(s); s++; } +} + +void main(void) { + foo("Bla"); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/strings.i frama-c-20111001+nitrogen+dfsg/tests/misc/strings.i --- frama-c-20110201+carbon+dfsg/tests/misc/strings.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/strings.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,108 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main main1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main6 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main main7 -journal-disable +/ + +char s1[]="hello\000 world"; +char s2[]="hello"; +char s5, s6; + +int u(void); + +char cc = 'a'; +char Q, R, S, T, U, V, W, X, Y, Z; + +char strcpy(chardst, charsrc) +{ + char* ldst=dst; + /@ loop pragma UNROLL_LOOP 20; / + while (ldst++ = src++) + ; + return dst; +} + +unsigned int strlen(char s) +{ + unsigned int l=0; + /@ loop pragma UNROLL_LOOP 20; / + while(s++ != 0) + l++; + return l; +} + +void main1(void) +{ + char p; + p = &s1[3]; + if (u()) R=(p-4); + + p = &s1[3]; + if (u()) S=(p+12); + + if (u()) + p = &s1[5]; + else + p = &s2[3]; + if (u()) T=(p-4); + + { + char a[10] = "Not ok"; + char b [5]; + if (u()) strcpy(b,a); + } + + s1[3]=cc; + s1[6]=cc; + return strlen(s1); +} + + +char s3="tutu"; +char s4="tutu"; +char s7="hello\x00 world"; +char s8="hello"; + +int main6(void) +{ + char s; + s = "toto"; + cc = s; + if (u()) + R = (s3 == s4); + if (u()) + S = (s1 == s2); + if (u()) + T = (s1 == s3); + if (u()) + U = (s7 == s8); + if (u()) + V = (s7 == s4); + if (u()) + W = (s7 + 1 == s8 + 1); + if (u()) + X = (s3 == s3); + s5 = (u()?s3:s8); + if (u()) + Y = ((u()?s3:s8) == s5); + s6 = (u()?(u()?s3:s8):s4); + if (u()) + Z = (s5 == s6); + if (u()) + Q = ("oh, hello"+4 == s7); + return cc; +} + +int main7(int d, int e, int f) +{ + char c=-1; + if (d) s5 = s3; else s5 = &c; + (f ? s5 + 2 : &c) = 'T'; + R=c; + s5=' '; + if (e) s6 = s3+1; else s6 = &c; + s6=cc; + c=s4; + return c; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct2.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct2.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,275 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f_precis -journal-disable +/ +struct st1 { + int a; + int b; +}; + +struct st2 { + int a; + int d[10]; + struct st1 b; + struct st1 e[10]; + struct st2 c; +}; + +struct st1 tabst[10], tabst2[10]; + +struct st2 tab_s[2]; +struct st2 tab_s1[2]; +struct st2 tab_s2[2]; +struct st2 tab_s3[2]; +struct st2 tab_s4[2]; + +struct st2 s1,s2,s4,s5,s6; +struct st1 s8,s7; + +typedef int Ttabl[5+5]; +Ttabl tabl; + +int tab1[2]; +int tab2[2]; +int tab3[2]; +int tab4[2]; +int tab5[2]; +int tab6[2]; + +int p, p2, p3, p4, p5, p6, p7; +int q,r,s,t; + +int a,b; + +void f_precis(int x, int i, int j, int k, int l, int m){ + +/* --------------------------- / +/ Scalaires / +/ --------------------------- / + + a = i; + +/ --------------------------- / +/ Structures / +/ --------------------------- / + + s1 = s2; + + s1.a = x; + + s1.b.a = x; + + s1.b = s8; + + s7 = s6.b; + +/ --------------------------- / +/ Tableaux / +/ --------------------------- / + + tab1[0] = 2; + + tab1[1] = 2; + + tab2[i] = 2; + + tab3[i+j] = k; + + tab4[tab2[i]] = 2; + + tab5[tab2[1]] = 2; + + tab6[tab2[i]+j] = 2; + + +/ --------------------------- / +/ Tableaux de structures / +/ --------------------------- / + + tab_s[0] = s2; / @tab_s[0...] / + + tab_s[1].a = x; + + tab_s1[i].b = s8; / @tab_s[?,b...] / + + tab_s2[tabl[0]] = s1; / @tab_s[?...] / + + tab_s3[tabl[1]].a = x; + + tab_s4[tabl[i]+x].a = x; + +/ --------------------------- / +/ Structures et tableaux / +/ --------------------------- / + + s1.d[1] = x; + + s2.d[i] = x; + +/ --------- / +/ Pointeurs / +/ --------- / + + p = &a; + + p = x; + + p = p + x; + + q = (int)0; + r = (int)0; + + *q = p; + + **r = a; + + p2 = &tab1[2]; + + p3 = &tab1[i]; + + b = (p3+2); + + p4 = p; + + p5 = (int ) 0x1000; + + p6 = (int)0; + + p6 = (int ) 0x1000 + i; + + p7 = p2 + 1; + +/* p8 = p2 - i; / + + s = (int)0; + + s = (int ) 0x1000; + + t = (int)0; + (t)[i] = 2; + +/* --------- / + + s8.b = &a; + + (s8.b) = x; + + s1.c = &s2; + + s1.c->a = x; + + s1.c->b = s8; + + s1.c->b.a = x; + + s1.c->b.b = &a; + + (s1.c->b.b) = x; + + s1.c->c = &s2; + + s1.c->c->a = x; + + s1.c->c->b = s8; + + s1.c->c->b.a = x; + + s1.c->c->b.b = &a; + + (s1.c->c->b.b) = x; + + s1.c->c->c = &s2; + + s1.c->c->c->a = x; + + s4.e[tabst[tab1[i+j]].a].a = (tab2[k] + s5.e[tabst2[tab3[l] + m].a].b); + +/------------------------------/ +/ Clauses From attendues / +/------------------------------/ +/ Clause From : @a[] From @i[]; / +/* Clause From : @s1[] From @s2[...]; / +/ Clause From : @s1[a] From @x[]; / +/* Clause From : @s1[b,a] From @x[]; / +/* Clause From : @s1[b] From @s8[...]; / +/ Clause From : @s7 From @s6[b...]; / +/ Clause From : @tab1[(0)] From ; / +/ Clause From : @tab1[(1)] From ; / +/ Clause From : @tab2[(?)] From @i[],@tab2[(?)]; / +/* Clause From : @tab3[(?)] From @i[],@j[],@k[],@tab3[(?)]; / +/* Clause From : @tab4[(?)] From @tab2[(?),],@i[],@tab4[(?)]; / +/ Clause From : @tab5[(?)] From @tab2[(2),],@tab5[(?)]; / +/* Clause From : @tab6[(?)] From @tab2[(?),],@i[],@j[],@tab6[(?)]; / +/* Clause From : @tab_s[(0)] From @s2[...]; / +/ Clause From : @tab_s[(1),a] From @x[]; / +/* Clause From : @tab_s1[(?),b] From @i[],@s8[...],@tab_s1[(?)]; / +/* Clause From : @tab_s2[(?)] From @tabl[(0),],@s1[...],@tab_s2[(?)]; / +/* Clause From : @tab_s3[(?),a] From @tabl[(1),],@x[],@tab_s3[(?)]; / +/ Clause From : @tab_s4[(?),a] From @tabl[(?),],@i[],@x[],@x[],@tab_s4[(?)]; / +/ Clause From : @s1[d,(1)] From @x[]; / +/* Clause From : @s2[d,(?)] From @i[],@x[],@s2[d,(?)]; / +/ Clause From : @p[] From @a[]; / +/ Clause From : @p[] From @x[]; / +/ Clause From : @p[] From @p[][],@x[]; / +/ Clause From : @q[] From @p[]; / +/ Clause From : @r[][] From @a[]; / +/* Clause From : @p2[] From @tab1[(2)]; / +/ Clause From : @p3[] From @tab1[(?)],@i[]; / +/* Clause From : @p4[] From @p[]; / +/* Clause From : @p5[] From @Pt!4096[]; / +/* Clause From : @p6[] From @Pt!4096[][],@i[]; / +/ Clause From : @s[] From @Pt!4096[]; / +/ Clause From : @t[][][(?)] From @i[],@t[][][(?)]; / +/* Clause From : @s8[b] From @a[]; / +/ Clause From : @s8[b,] From @x[]; / +/ Clause From : @s1[c] From @s2[]; / +/ Clause From : @s1[c,][a] From @x[]; / +/ Clause From : @s1[c,][b] From @s8[...]; / +/* Clause From : @s1[c,][b,a] From @x[]; / +/ Clause From : @s1[c,][b,b] From @a[]; / +/* Clause From : @s1[c,][b,b,] From @x[]; / +/* Clause From : @s1[c,][c] From @s2[]; / +/* Clause From : @s1[c,][c,][a] From @x[]; / +/* Clause From : @s1[c,][c,][b] From @s8[...]; / +/ Clause From : @s1[c,][c,][b,a] From @x[]; / +/* Clause From : @s1[c,][c,][b,b] From @a[]; / + +/ Clause From : @s1[c,][c,][b,b,] From @x[]; / +/ Clause From : @s1[c,][c,][c] From @s2[]; / +/ Clause From : @s1[c,][c,][c,][a] From @x[]; / +/ Clause From : @s4[e,(?),a] From / +/ @tabst[(?),a,],@tab1[(?),],@i[],@j[],@s5[e,(?),b,][(?),], / +/ @tab2[(?),],@k[],@tabst2[(?),a,],@tab3[(?),],@l[],@m[],@s4[e,(?)]; / + + +} + + +static void fonc (int p, int x) { + (p+3) = p + x; +} + +int Tab[10]; +int * P; + +void f_tab_0 (int y) { + fonc (Tab, y); +} +void f_tab_2 (int y) { + fonc (Tab+2, y); +} +void f_p_0 (int y) { + fonc (P, y); +} +void f_p_2 (int y) { + fonc (P+2, y); +} + +void g (int * p) { + p = p+1; +} +int test_g (void) { + int x = 3; + g (&x); + return x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct3.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct3.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct3.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct3.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,42 @@ +struct st1 { + int a; + int b; +}; + +struct st2 { + int a; + int d[10]; + struct st1 b; + struct st1 e[10]; + struct st2 c; +}; + +struct st1 tabst[10], tabst2[10]; + +struct st2 tab_s[2]; +struct st2 tab_s1[2]; +struct st2 tab_s2[2]; +struct st2 tab_s3[2]; +struct st2 tab_s4[2]; + +struct st2 s1,s2,s4,s5,s6; +struct st1 s8,s7; + +void main () { + s1.a=2; + s1.c = &s1; + s1.d[0] = 1; + s1.d[1] = 2; + s1.d[2] = 2; + + s1.b.a = 3; + s1.d[8] = 2; + s1.d[9] = 2; + + s1.d[10] = 2; + + + + + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct_array.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct_array.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct_array.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct_array.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,14 @@ +struct st1 { + int a; + int b; + int pp; + int p; +}; +int outp; +int x,y,z1,z2,z3,z4; +struct st1 T[22] = { {1,2,0,&x}, {&z1,&z2,&z3,&y},{&z4,2,0,&x},{1,2,0,&x} }; +int main (char c) { + outp = T[c].p; + outp = 5; + z1++; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct_call.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct_call.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct_call.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct_call.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,36 @@ +/* run.config + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -journal-disable -machdep ppc_32 +/ +int G= 77; +int GG; + +struct A { int x; int y; }; +struct B { int z; int t; }; + +struct A t[4]; +struct A tt[5]; + +int g(struct A s) +{ + Frama_C_show_each_G(s); + return s.y; // (((struct B)(&t[1]))).t; + +} + +struct A create_A() { + struct A r={0,0}; + r.x = 1; +// r.y = 2; + Frama_C_show_each_GG(r); + return r; +} + +int main(void) +{ + int i = 2 - 1; + t[1].y = G; + GG = g(tt[i]); + struct A init = create_A(); + return g(t[i]); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct_deps.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct_deps.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct_deps.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct_deps.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +struct Tstr { int a; int b; }; + +int f (struct Tstr ps) { + return ps->a; +} + +int f3(intp) { return p ;} + +int main (int x, int y) { + struct Tstr s = {x, y}; +// return f3(&s); + return f(&s); +} + +int f2 (struct Tstr s) { + return s.a; +} + +int main2 (int x, int y) { + struct Tstr s = {x, y}; + return f2(s); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,78 @@ +int f (int a, int b){ + int w; + struct t1 { int x; int y;} v1,v2; + v1.x = w; + if (w) w=1; + v1=v2; + if (v1.y) v1.x = a; + v1.y = b; + a = b; + return v1.x; + } +int GG; +int simple (int a, int b){ + int w=3; + struct t1 { int x; int y;} v1,v2; + v2.x=3; + v2.y=5; + v1=v2; + return v1.x; +} + + +int less_simple (int a, int b){ + int w=3; + struct t1 { int x; int y;} v1,v2,v3; + v2.x=3; + v2.y=5; + v3.x=7; + v3.y=9; + v1=a?v2:v3; + return v1.x; +} + + int w; +struct t1 { int x; int y;} v1; + struct t1 v2; + struct t2 { int x; int y;} v3; + +int T[2] = { 1, 1 }; +int R1, R2; + +int main (int a, int b){ + R1 = 1 + (int)((char)T+2); + (char)T = 2; + R2 = 1 + T[0]; + v1 = v2; + v1.x = a+b; + w = v1.x; + if (a) +{ + + + v2.x = a; + / v3.x = b; + w = w + v2.x + v3.x;/ + } + return w; +} + +int fonc2 (int a, int b){ + int w; + struct t1 { int x; int y;} v1; + v1.x = a+b; + w = v1.x; + return w; +} + +void mune (int a, int b){ + v1=v2; + v1.x = a; +} + +int G; + +void mtwo (int c1,int c2) { + if (c1) v1.x = G; + v1.y = v1.x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct_incl.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct_incl.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct_incl.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct_incl.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,50 @@ +struct st1 { + int a; + long b; +}; + +struct st2 { + int a; + int d[10]; + struct st1 b; + struct st1 e[10]; + struct st2 c; +}; + +struct st1 tabst[10], tabst2[10]; + +struct st2 tab_s[2]; +struct st2 tab_s1[2]; +struct st2 tab_s2[2]; +struct st2 tab_s3[2]; +struct st2 tab_s4[2]; + +struct st2 s1,s2,s4,s5,s6; +struct st1 s8,s7; + +long x,y,z,t; + +void main () { + x = &s1.d[9]; + y = &s1.d[10]; + z = &s1.b; + + + + s1.a=2; + s1.c = &s1; + s1.d[0] = 2; + s1.d[1] = 2; + s1.d[2] = 2; + + s1.b.a = 3; + + s1.d[5] = 7; + + + s1.d[8] = 8; + s1.d[9] = 8; + + s1.d[10] = 777; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/struct_p_call.i frama-c-20111001+nitrogen+dfsg/tests/misc/struct_p_call.i --- frama-c-20110201+carbon+dfsg/tests/misc/struct_p_call.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/struct_p_call.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ + +typedef struct S {char v; int w;} U; + + +void f(U* G1) { + G1->w = 0; + G1->v = 1; + return; +} + + +char main () { + U H1; + f(&H1); + return H1.v; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/switch2.i frama-c-20111001+nitrogen+dfsg/tests/misc/switch2.i --- frama-c-20110201+carbon+dfsg/tests/misc/switch2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/switch2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,20 @@ +/run.config + STDOPT: +"-simplify-cfg" +"-check" + / + +int f(int x) { return x+1; } + +extern void g(int,int); + +int main () { + int exit_loop = 0; + switch (16) { + case 16: + g(exit_loop++,({exit_loop++; exit_loop++;f(exit_loop);})); + break; + default: + exit_loop = 1; + break; + } + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/switch.i frama-c-20111001+nitrogen+dfsg/tests/misc/switch.i --- frama-c-20110201+carbon+dfsg/tests/misc/switch.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/switch.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,55 @@ +/* run.config + OPT: -float-normal -memory-footprint 1 -val -deps -out -input -journal-disable + OPT: -float-normal -memory-footprint 1 -val -deps -out -input -journal-disable -simplify-cfg +/ + +int result1, result3, result4; +int result2=7; +double d2; + +int main (int c, int d, int e, int f, double d1, long l) { + + switch (d) + { + case 1: + result1 = 1; + break; + case 2: + result1 = 2; + break; + case 3: + result1 = 3; + case 4: + result1 = 4; + break; + } + + switch(c) + { + case 0: CEA_F(c); return c; + case 2: return c; + } + + switch (e) + { + case 0: result2 = e; + } + f = f ? 14 : 42; + switch (f==14) + { + case 0: result3 = f; + } + + switch(d1>=0.0) + { + case 0: d2=-d1;break; + default: d2=d1; break; + } + + switch(l) + { + case 0x0FFFFFFF: result4 = 1; break; + case 0xFFFFFFFF: result4 = 2; break; + } + return 77; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/syntactic_hook.i frama-c-20111001+nitrogen+dfsg/tests/misc/syntactic_hook.i --- frama-c-20110201+carbon+dfsg/tests/misc/syntactic_hook.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/syntactic_hook.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,31 @@ +/ run.config + OPT: -load-script tests/misc/syntactic_hook.ml -print +/ + +int f(void); + +int f(int); //warns conflicting decls + +int h(const int); + +int h(int x) { return x; } // warns different decls. + +int k(int ); + +int k(int x) { return (x)++; } + +int main () { + int x = 0; int y = 0; + int t(void); + x=t(); + x++; + x; // warn ignore pure exp + g(3); // warn implicit proto + x = sizeof(x++); // warn drop side-effect + x = x++ && x; + y = x && x++; // warn conditional side-effect + y = x && (x++ || x); // warn conditional side-effect + y = x && (x || x++); // warn conditional side-effect + y = x ? x++ : x++; // warn conditional side-effect + return x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/syntactic_hook.ml frama-c-20111001+nitrogen+dfsg/tests/misc/syntactic_hook.ml --- frama-c-20110201+carbon+dfsg/tests/misc/syntactic_hook.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/syntactic_hook.ml 2011-10-10 08:39:03.000000000 +0000 @@ -27,20 +27,15 @@ let warn_pure_exp f e = let loc = e.eloc in - let source = { Log.src_file = (fst loc).pos_fname; - Log.src_line = (fst loc).pos_lnum } - in - Kernel.warning ~source "[SH]: function %s, pure expression %a is dropped" + Kernel.warning ~source:(fst loc) + "[SH]: function %s, pure expression %a is dropped" f (!Ast_printer.d_exp) e ;; Cabs2cil.register_ignore_pure_exp_hook warn_pure_exp;; let warn_proto vi = - let source = { Log.src_file = (fst vi.vdecl).pos_fname; - Log.src_line = (fst vi.vdecl).pos_lnum } - in - Kernel.warning ~source "[SH]: implicit declaration for prototype %a" + Kernel.warning ~source:(fst vi.vdecl) "[SH]: implicit declaration for prototype %a" (!Ast_printer.d_ident) vi.vname ;; @@ -48,11 +43,9 @@ ;; let warn_conflict oldvi vi reason = - let source = { Log.src_file = (fst vi.vdecl).pos_fname; - Log.src_line = (fst vi.vdecl).pos_lnum; } - in Kernel.warning - ~source "[SH]: conflict with declaration of %a at line %d: %s" + ~source:(fst vi.vdecl) + "[SH]: conflict with declaration of %a at line %d: %s" !Ast_printer.d_ident vi.vname (fst oldvi.vdecl).pos_lnum reason @@ -61,11 +54,8 @@ Cabs2cil.register_incompatible_decl_hook warn_conflict;; let warn_distinct oldvi vi = - let source = { Log.src_file = (fst vi.vdecl).pos_fname; - Log.src_line = (fst vi.vdecl).pos_lnum; } - in Kernel.warning - ~source + ~source:(fst vi.vdecl) "[SH]: definition of %a does not use exactly the same prototype as \ declared on line %d" !Ast_printer.d_ident vi.vname @@ -75,18 +65,14 @@ Cabs2cil.register_different_decl_hook warn_distinct;; let warn_local_func vi = - let source = { Log.src_file = (fst vi.vdecl).pos_fname; - Log.src_line = (fst vi.vdecl).pos_lnum; } - in - Kernel.warning ~source + Kernel.warning ~source:(fst vi.vdecl) "[SH]: definition of local function %a" !Ast_printer.d_ident vi.vname ;; Cabs2cil.register_local_func_hook warn_local_func;; let warn_drop_effect olde e = - let source = Cil.source e.eloc in - Kernel.warning ~source + Kernel.warning ~source:(fst e.eloc) "[SH]: dropping side effect in sizeof: %a is converted to %a" Cprint.print_expression olde !Ast_printer.d_exp e @@ -95,7 +81,7 @@ Cabs2cil.register_ignore_side_effect_hook warn_drop_effect let warn_cond_effect orig e = - let source = Cil.source e.expr_loc in + let source = fst e.expr_loc in Kernel.warning ~source "[SH]: side effect of expression %a occurs in \ conditional part of expression %a. It is not always executed" diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/syntax.i frama-c-20111001+nitrogen+dfsg/tests/misc/syntax.i --- frama-c-20110201+carbon+dfsg/tests/misc/syntax.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/syntax.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,20 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -ulevel 22 -journal-disable +/ + +// #include <stdio.h> +int a; +int t[25]; +int main() +{ + int i; + for (i=-10; i< 10; i++) + { + t[i+10] = (int)(i+10)-(int)10; + } +} + + + +// diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/tab1.i frama-c-20111001+nitrogen+dfsg/tests/misc/tab1.i --- frama-c-20110201+carbon+dfsg/tests/misc/tab1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/tab1.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +int G[10] ={0}; + +void main (int x) { + + if (0 <= x) + { + G[0] =x; + } + + if (0 >= x) + { + G[1] =x; + } + + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/termination.i frama-c-20111001+nitrogen+dfsg/tests/misc/termination.i --- frama-c-20110201+carbon+dfsg/tests/misc/termination.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/termination.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,35 @@ +int G[10]= {0}; + +int X; + +void loop(int d) { +// int p = &d; + +// G[1] = 6; + if(d) ; else ; + X=0; + + if(d) X=1; else L:; + + X=2; +// while(1) { X = 2; G[2] = 77; } + return; +} + + + +void main(int c) { +/* + if (c) {loop (c);} + if (c+1) {loop (c);} + if (c+2) {loop (c);} + if (c+3) {loop (c);} + + if (1) loop (0); + G[2] = 5; +/ + +// c = 1; + loop(c?1:0); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/test_array.i frama-c-20111001+nitrogen+dfsg/tests/misc/test_array.i --- frama-c-20110201+carbon+dfsg/tests/misc/test_array.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/test_array.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,16 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main g -journal-disable -unspecified-access +/ +int j; +int t[10]; + +void g(int i){ + for (i=1; + i < 1000; + i++) + t[i] = j+i++; + + j=1; + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/test.i frama-c-20111001+nitrogen+dfsg/tests/misc/test.i --- frama-c-20110201+carbon+dfsg/tests/misc/test.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/test.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main inst_F6 -absolute-valid-range 0x200-0x199 + OPT: -memory-footprint 1 -val -deps -out -input -main f +/ +void inst_F6(int v,int n){ int t[3]; t[1] = 4; + int i,j,ecart,tmp; + { int i = 0 ; i++ ; j = i; }; + for (ecart = n/2; ecart >0; ecart /=2) + for (i = ecart; i < n; i++) + for (j = i-ecart; j>=0 && v[j]>v[j+ecart]; j = j-ecart){ + tmp = v[j]; + v[j] = v[j+ecart]; + v[j+ecart] = tmp; + } +} + +void f() { + int t[88888]; + t[0] = 99; + t[1] = t[100]; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/threat_array.i frama-c-20111001+nitrogen+dfsg/tests/misc/threat_array.i --- frama-c-20110201+carbon+dfsg/tests/misc/threat_array.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/threat_array.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,17 @@ +int T [10]; +int (p)[10]; +void main (int c) { + +/@ assert \valid(T + c); // synthesized alarm caused by a memory access +/ +/@ assert \valid(T); / + + p = (int ()[10])&T[5]; + + if(!c) { + /@ assert \valid( p); // means that the first element of p is valid ! / + } + + T[c] = 4; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/threat_if.i frama-c-20111001+nitrogen+dfsg/tests/misc/threat_if.i --- frama-c-20110201+carbon+dfsg/tests/misc/threat_if.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/threat_if.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,22 @@ +int p; +int l,m; +int i; +int X=-992; + +void main(int i) { + int G = 258+128; + signed char c; + + + if(i==0) p = &l; + if(i==0) p = 1; + + c = (signed char)G; // -126 + G = c; + printf("%d\n",G); + return G; + + for (i=-1000+8; i<2008; i+=100) + X = i; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/typedef_function.i frama-c-20111001+nitrogen+dfsg/tests/misc/typedef_function.i --- frama-c-20110201+carbon+dfsg/tests/misc/typedef_function.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/typedef_function.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,9 @@ +typedef void T(void); +extern T F476 ; + +static T* const G209[] = { 0,& F476}; + +int main () { + int i = (int)G209[0]; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/typeof.i frama-c-20111001+nitrogen+dfsg/tests/misc/typeof.i --- frama-c-20110201+carbon+dfsg/tests/misc/typeof.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/typeof.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,4 @@ +extern void y(); +void main() { + (typeof(y()))0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/ulongvslonglong.i frama-c-20111001+nitrogen+dfsg/tests/misc/ulongvslonglong.i --- frama-c-20110201+carbon+dfsg/tests/misc/ulongvslonglong.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/ulongvslonglong.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,19 @@ +/* run.config + OPT: -memory-footprint 1 -val -journal-disable -machdep x86_64 + OPT: -memory-footprint 1 -val -journal-disable +/ + +int x; +long x2; +unsigned long x9[6][2]; + +main(){ + x2 = 2793414595; + for (int i = 0; i < 6; i++) + { + for (int j = 0; j < 2; j++) + x9[i][j] = 1U; + } + x = ((0x090E7AF82577C8A6LL | x9[0][1]) <= (~(x2 || x9[0][1]))); + return x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/undef_fct.i frama-c-20111001+nitrogen+dfsg/tests/misc/undef_fct.i --- frama-c-20110201+carbon+dfsg/tests/misc/undef_fct.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/undef_fct.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,5 @@ +int main() +{ + return f(3); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/undefined_sequence2.i frama-c-20111001+nitrogen+dfsg/tests/misc/undefined_sequence2.i --- frama-c-20110201+carbon+dfsg/tests/misc/undefined_sequence2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/undefined_sequence2.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,71 @@ +/ run.config + STDOPT: +"-unspecified-access" +/ +/ based on an example from J. Regehr on the why list / +/ precondition: false / +int a[2]; + +int +multiple_update_wrong_1 (int x, int y) +{ + return (x = 0) + (x = 0); +} + +/ precondition: false / +int +multiple_update_wrong_2 (int i) +{ + i = ++i + 1; + return i; +} + +/ precondition: false / +int +multiple_update_wrong_3 (int i) +{ + a[i++] = i; + return i; +} + +/ precondition: x != y / +int +multiple_update_unsafe (int x, int y) +{ + return (x = 0) + (y = 0); +} + +/ precondition: true / +int +multiple_update_safe (int x, int y) +{ + if (x == y) + { + return 0; + } + else + { + return (x = 0) + (y = 0); + } +} + +int main () { + int b,c; + b = 0; + c = 0; + + multiple_update_wrong_1(&b, &c); + + multiple_update_wrong_2(b); + + multiple_update_wrong_3(c); + + multiple_update_unsafe(&b,&c); // does not lead to an alarm + + multiple_update_unsafe(&b, &b); + + multiple_update_safe(&b,&c); // does not lead to an alarm + + multiple_update_safe(&c,&c); // does not lead to an alarm + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/undefined_sequence.i frama-c-20111001+nitrogen+dfsg/tests/misc/undefined_sequence.i --- frama-c-20110201+carbon+dfsg/tests/misc/undefined_sequence.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/undefined_sequence.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,56 @@ +/ run.config + STDOPT: +"-unspecified-access" + STDOPT: +"-no-unspecified-access" +/ +/ detection of undefined behavior for read/write accesses + in unspecified order +/ +int G[10]; + +int f (int x) { return x+1;} +int g (int x) { return x+2;} + +int r, H; +int h(int i) +{ + r = r++; //UB + i = r++; //Not UB + H = i; + return i; +} + +int func(int x, int y) { return x + y; } + +int main (int a) { + int x, y, i,j; + x = 0; + y = &x; + i=(x=0)+(y=1); + for (i=0; i < 10; i++) G[i] = i; + i=j=0; + while (j<10 && i<10) G[j++] = G[i++]; + i=j=0; + while (j<10 && i<10) G[j++] += G[i++]; + i=j=0; + while(j<10 && i<10) { + G[j] = G[j++]; // UB + G[i++] = G[i]; // UB + } + i=j=0; + while(j<10 && i<10) { + G[j] += G[j++]; // UB + G[i++] += G[i]; // UB + } + i = f(g(3)+x) + x++; //UB + y = f(g(3)+x); // no UB: x is read to write to x (through an alias) + if (a) + r = h(1) + h(2); // missing alarm! + + y = &G[2]; + + y = (G[2] < (func((0U || + (((G[2] ^ G[2]) <= G[2]) < ((y) || G[2]))), 5))); + + int (my_f) (int) = f; + return (my_f=g, f(1)) + my_f(2); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/uninit.i frama-c-20111001+nitrogen+dfsg/tests/misc/uninit.i --- frama-c-20110201+carbon+dfsg/tests/misc/uninit.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/uninit.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,5 @@ +int main () { + int i; + i++; + return i; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/uninitialized_gnubody.i frama-c-20111001+nitrogen+dfsg/tests/misc/uninitialized_gnubody.i --- frama-c-20110201+carbon+dfsg/tests/misc/uninitialized_gnubody.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/uninitialized_gnubody.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,5 @@ +int main () { + int x = 0; + x = ({ int y = 0; y++; y + 1;}) + 42; + return x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/unroll.i frama-c-20111001+nitrogen+dfsg/tests/misc/unroll.i --- frama-c-20110201+carbon+dfsg/tests/misc/unroll.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/unroll.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,78 @@ +void main (int c) { + int G=0,i; + int MAX = 12; + int JMAX=5; + int j; + /@ loop pragma UNROLL_LOOP 14; / // first loop unrolled 14 times + for (i=0; i<=MAX; i++) + { + G+=i; + } + /@ loop pragma UNROLL_LOOP 124; / + for (i=0; i<=10MAX; i++) + { + G+=i; + } + /@ loop pragma UNROLL_LOOP 14; / + for (i=0; i<=MAX; i++) + { + j=0; + /@ loop pragma UNROLL_LOOP 50; / + while (j<=JMAX) + { + G+=i; + j++; + } + } + +//@ loop pragma UNROLL_LOOP 128; + do { + G += i; + i++; + j--; + } + while (i<=256 || j>=0); + +//@ loop pragma UNROLL_LOOP 10; + do + { if(c) continue; + + if(c--) goto L; + c++; + L: c++; + } + while(c); + +//@ loop pragma UNROLL_LOOP c; + while(0); + +} + +#if 0 +struct T { unsigned long long addr; + unsigned long long size; + unsigned long type; } t_biosmap[10]; + +struct T * const g_biosmap = t_biosmap; +struct T * biosmap; +int main2(int c,signed char nr_map) { + biosmap = g_biosmap; + if (nr_map<2) return (-1); + +//@ loop pragma UNROLL_LOOP 200; + do { + unsigned long long start = biosmap->addr; + unsigned long long size = biosmap->size; + unsigned long long end = start + size; + unsigned long type = biosmap->type; + CEA_F(nr_map); + if (start>end) return -1; + if (c) { + start = 0x100000L; + size = end - start; continue; }; + } + while (biosmap++,--nr_map); + + return 0; +} +#endif diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/unroll_labels.i frama-c-20111001+nitrogen+dfsg/tests/misc/unroll_labels.i --- frama-c-20110201+carbon+dfsg/tests/misc/unroll_labels.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/unroll_labels.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,31 @@ +/* run.config + OPT: -val -main main -check -print + OPT: -val -main main2 -check -print -slevel 2 +/ + + +void main () { + int j = 0; + /@ loop pragma UNROLL_LOOP 4; / + for (int i=1;i<4;i++) { + switch (i) { + case 1: j+=1; break; + case 2: j+=3; break; + case 3: j+=5; break; + case 4: j+=7; break; + default: j=0; + } + } +} + +void main2 () { + /@ loop pragma UNROLL_LOOP 2; / + for (int i=0;i<2;i++) { + for (int j=0;j<2;j++){ + i += 1; + goto foo; + i += 1; + foo: + } + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/unroll_simple.i frama-c-20111001+nitrogen+dfsg/tests/misc/unroll_simple.i --- frama-c-20110201+carbon+dfsg/tests/misc/unroll_simple.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/unroll_simple.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,24 @@ +void main (int c) { + int G=0,i=4; + int MAX = 12; + int JMAX=5; + int j=3; + +//@ loop pragma UNROLL_LOOP 128; + do { + G += i; + i++; + j--; + } + while (i<=256 || j>=0); + +//@ loop pragma UNROLL_LOOP 10; + do + { if(c) continue; + + if(c--) goto L; + c++; + L: c++; + } + while(c); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/unroll_visit.i frama-c-20111001+nitrogen+dfsg/tests/misc/unroll_visit.i --- frama-c-20110201+carbon+dfsg/tests/misc/unroll_visit.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/unroll_visit.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +/ run.config + STDOPT: +"-print" + / +void main() { + /@ loop pragma UNROLL_LOOP 2; / + for(int i=0; i<100; i++) { + i--; + //@ assert i<100; + i++; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/val6.i frama-c-20111001+nitrogen+dfsg/tests/misc/val6.i --- frama-c-20110201+carbon+dfsg/tests/misc/val6.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/val6.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,28 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -absolute-valid-range 0x1-0xFFFFF -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main f1 -absolute-valid-range 0x1-0xFFFFF -journal-disable +*/ +char **c,a,b,y; +int x; + +int f() { + a = 'b'; + b = &a; + c = &b; + x = (int)c; + y = (char)x; + ((char)0x12) = &b; + ((char**)0x12)='a'; + +} + +int f1() { + ((char)17) = 27; + ((char)19) = 29; + + x = c?17:19; + b = (char)x; + b = 0; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/val9.i frama-c-20111001+nitrogen+dfsg/tests/misc/val9.i --- frama-c-20110201+carbon+dfsg/tests/misc/val9.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/val9.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,59 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable +/ +int TT[10]={1,2,3}; +int T[10]={1,2,3}; +int i,a,b; +int a7, b7; + +int O1[20]; +int O2[20]; +int p; + +int x2,b2,a2; + +void f() { + for (i = 0; i <= 8; i++) { + TT[i] = i; + ((int)((char)&(TT[i]) + 1)) = 0; + } + + a = 1; + if (b) i=5; else i=6; + a=3; + if (i>=2) { a = i ; T[i] = 7 ; } + + for (i = 0; i <= 8; i++) { + (char ) &a = 1; +b = a; + + ((int)(((char)&(T[i])) + 1)) = 0; + } + + + + + a7 = 'a'; + (char ) &a7 = 1; + b7 = (char)a7; + + + ((int)O1)[1]=17; + ((char)O1)[1]=18; + + + ((int)O2)[0]=10; + ((char)O2)[1]=11; + + O1[6]=0; + p=O1+9; + p=1; + + + x2 = 777; + a2 = (int)&x2; + b2 = (int) a2; + ((int)a2) = 0; + b2=b2+1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/val_if.i frama-c-20111001+nitrogen+dfsg/tests/misc/val_if.i --- frama-c-20110201+carbon+dfsg/tests/misc/val_if.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/val_if.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,47 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main f1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main f2 -journal-disable +/ +int i,j,x,k,l,m,n,d; +void f(int c){ + int j = 12; + if (c) x=1; else x = -1; + + if (x<=-2) j = x; + + i = 10; +} + +void f1(int c){ + j= 13; + k= 14; + l= 15; + if (c) x=1; else x = -1; + + if (x<=0) + {j = x; + if (x<=-2) k = x; + l=x; + } + + i = 10; +} + +void f2(int c) { + j= 16; + k= 17; + l= 18; + if (c) x=1; else { + if (d) x=2; else x = 3; + } + + if (x <= 1 || x>=3 ) + { x = 2; + j = x; + } + else { x++ ; k = x;}; + + i = 10; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/val_ptr.i frama-c-20111001+nitrogen+dfsg/tests/misc/val_ptr.i --- frama-c-20110201+carbon+dfsg/tests/misc/val_ptr.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/val_ptr.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,55 @@ +/ run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main f -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main f1 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main f3 -journal-disable + OPT: -memory-footprint 1 -val -deps -out -input -main f2 -journal-disable +/ +int i,j,x,k,l,m,n,d,a,b,c; +int p; + +void f(int c) { + j= 16; + k= 17; + l= 18; + a= 11; b = 12; d= 13; + + + p = &a; + if (c) p=&a; else { + a = 10; + if (d) p=&b; else p = &d; + } + if (a <= 10) + { j = p; + k = a; + } + else { k = p ;}; + + i = 10; +} + +int T[8],p; +void f1() { + for (p=T;p==&T[8];p++) + p = 0 ; +} + + +void f3() { + p = T; + if (p + 8 <= &T[8]) + p = 0 ; +} + +void f2(int c) +{ + j = 3; + a = 1; + b = 2; + c = 0; + if (!c) p = &a; else p = &b; + if (!p) + j = p; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/video_detect.i frama-c-20111001+nitrogen+dfsg/tests/misc/video_detect.i --- frama-c-20110201+carbon+dfsg/tests/misc/video_detect.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/video_detect.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,33 @@ +int G; + +typedef short u16; + +static int detect_video(void video_base) +{ + volatile u16 p = (u16 )video_base; +// CEA_F(p,p[0]); + u16 saved1 = p[0]; + u16 saved2 = p[1]; + int video_found = 1; + + + p[0] = 0xAA55; + p[1] = 0x55AA; + if ( (p[0] != 0xAA55) || (p[1] != 0x55AA) ) + video_found = 0; + + p[0] = 0x55AA; + p[1] = 0xAA55; + if ( (p[0] != 0x55AA) || (p[1] != 0xAA55) ) + video_found = 0; + + p[0] = saved1; + p[1] = saved2; + + return video_found; +} + +int main(void) { + void ADDR=(void)0x20; + return(detect_video(ADDR)); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/vis_spec.i frama-c-20111001+nitrogen+dfsg/tests/misc/vis_spec.i --- frama-c-20110201+carbon+dfsg/tests/misc/vis_spec.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/vis_spec.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,11 @@ +/ run.config + DONTRUN: bts 0727. Not fixed yet + OPT: -load-script tests/misc/vis_spec.i +/ + +//@ assigns \nothing; +void g () ; + +//@ assigns \nothing; +void f () { g(); } + diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/vis_spec.ml frama-c-20111001+nitrogen+dfsg/tests/misc/vis_spec.ml --- frama-c-20110201+carbon+dfsg/tests/misc/vis_spec.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/vis_spec.ml 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,37 @@ +open Cil_types +open Cil + +class pathcrawlerVisitor prj = +object(self) + inherit Visitor.frama_c_copy prj + + method vspec sp = + Format.printf "Considering spec of function %s@." + (Kernel_function.get_name (Extlib.the self#current_kf)); + (match self#current_func with + | Some f -> + if f.svar.vname ="f" then ( + Format.printf "Funspec of f is '%a' through visitor@." + Cil.d_funspec sp; + Format.printf "It is '%a' through get_spec@." + Cil.d_funspec + (Kernel_function.get_spec (Globals.Functions.get f.svar)); + ) + | None -> + Format.printf "Function prototype; Funspec is '%a'@." + Cil.d_funspec sp; + ); + DoChildren +end + +let startup () = + let cil_file = Ast.get () in + Format.printf "Starting visit@."; + let prj = File.create_project_from_visitor "pcanalyzer" + (fun prj -> new pathcrawlerVisitor prj) + in + Format.printf "End visit@."; + Project.set_current prj; +;; + +let () = Db.Main.extend startup diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/volatile.i frama-c-20111001+nitrogen+dfsg/tests/misc/volatile.i --- frama-c-20110201+carbon+dfsg/tests/misc/volatile.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/volatile.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,47 @@ +int volatile G = 1; +volatile int F, E, X, Y, pV; + +int k = 1, x = 2, y = 3; +int a,b,c,d,e,f,g,h,i,j,l,m,n,o, pv; + +struct s { int a; volatile int b; } s1,s2={1,1}; + +struct sv { int a; volatile int b; }; + +volatile struct sv sv1, sv2={1,1}; + +int main () { + G = G; + k = G; + + / reading an uninitialized volatile variable / + a = F ? 11 : 12; + + / relations involving volatile variables / + b = F; + c = F; + d = b - c; + e = F - F; + g = F; + f = F - g; + l = F + 1; + m = 2 + F; + n = F - l; + o = m - l; + + / lval to lval assignment to volatile variable / + h = 1; + E = h; + + / assignement via pointer / + X = -1; + Y = -1; + pv = (int ) &X; + pv = x; / assignment to volatile X / + x = pv; + pV = &Y; + pV = y; / assignment to volatile Y / + y = pV; + + return Y; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/wide_string.c frama-c-20111001+nitrogen+dfsg/tests/misc/wide_string.c --- frama-c-20110201+carbon+dfsg/tests/misc/wide_string.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/wide_string.c 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,13 @@ +#include "share/libc/stddef.h" + +int main() { + + // String literals are lvalues + char (p)[4] = &("bar"); + wchar_t (q)[4] = &(L"foO"); + + if((p)[1] != 'a') return 1; + if((q)[1] != 'o') return 2; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/misc/with_comment.i frama-c-20111001+nitrogen+dfsg/tests/misc/with_comment.i --- frama-c-20110201+carbon+dfsg/tests/misc/with_comment.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/misc/with_comment.i 2011-10-10 08:39:03.000000000 +0000 @@ -0,0 +1,36 @@ +/* run.config + GCC: + OPT: -memory-footprint 1 -val -deps -out -input -main main2 -journal-disable +/ +/ Commentaire avant G comment/ / Commentaire avant G2 comment/ +static int G; +/ Commentaire apres G avant main comment/ + + +int main2 () { +/ Commentaire apres main comment/ + int i; +/ Commentaire apres int i comment + Big Comment line 1 + Bif Comment line 2 / + G = 0; + +/ Commentaire avant loop comment/ + /@ loop pragma UNROLL_LOOP 0; / + for(i=0; i<=10; i++) + G++; + +// AVANT j + {int / milieu jcomment/ j; + j = / milieu j 2comment/ 0; } +// APRES j + + return i; +} + +/ ICI avant H comment/ +static int H; +/ ICI apres H comment/ +// fin + +int HHH; diff -Nru frama-c-20110201+carbon+dfsg/tests/occurrence/ptr_assert.i frama-c-20111001+nitrogen+dfsg/tests/occurrence/ptr_assert.i --- frama-c-20110201+carbon+dfsg/tests/occurrence/ptr_assert.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/occurrence/ptr_assert.i 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,18 @@ +/ run.config + GCC: + STDOPT: +"-occurrence" +/ + +int x, y; + +int main(int z) { + int p = &x, q; + p = 0; + /@ assert (x == 0); / + q = &y; + p = q; + q = 1; + p = 2; + /@ assert (y == 2 && q == 2 && p == 2 && x == 0); / + return z; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/annot.c frama-c-20111001+nitrogen+dfsg/tests/pdg/annot.c --- frama-c-20110201+carbon+dfsg/tests/pdg/annot.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/annot.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ /* run.config - OPT: -fct-pdg f1 -main f1 -journal-disable - OPT: -fct-pdg loop -main loop -journal-disable + OPT: -fct-pdg f1 -main f1 -journal-disable -pdg-print -pdg-verbose 2 + OPT: -fct-pdg loop -main loop -journal-disable -pdg-print -pdg-verbose 2 / int G; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/call.c frama-c-20111001+nitrogen+dfsg/tests/pdg/call.c --- frama-c-20110201+carbon+dfsg/tests/pdg/call.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/call.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config GCC: - OPT: -lib-entry -main g -pdg -dot-pdg tests/pdg/call -journal-disable + OPT: -lib-entry -main g -pdg -dot-pdg tests/pdg/call -journal-disable -pdg-print -pdg-verbose 2 / / Ne pas modifier : exemple utilis� dans le rapport. / diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/calls_and_implicits.c frama-c-20111001+nitrogen+dfsg/tests/pdg/calls_and_implicits.c --- frama-c-20110201+carbon+dfsg/tests/pdg/calls_and_implicits.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/calls_and_implicits.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config * GCC: - * OPT: -fct-pdg main -inout -journal-disable + * OPT: -fct-pdg main -inout -journal-disable -pdg-print -pdg-verbose 2 * / diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/calls_and_struct.c frama-c-20111001+nitrogen+dfsg/tests/pdg/calls_and_struct.c --- frama-c-20110201+carbon+dfsg/tests/pdg/calls_and_struct.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/calls_and_struct.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config GCC: - OPT: -deps -input -out -inout -pdg -journal-disable + OPT: -deps -input -out -inout -pdg -journal-disable -pdg-print -pdg-verbose 2 / struct Tstr { int a; int b; int c; }; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/decl_dpds.c frama-c-20111001+nitrogen+dfsg/tests/pdg/decl_dpds.c --- frama-c-20110201+carbon+dfsg/tests/pdg/decl_dpds.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/decl_dpds.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config GCC: - OPT: -fct-pdg main -journal-disable + OPT: -fct-pdg main -journal-disable -pdg-print -pdg-verbose 2 / extern int G; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/doc_dot.c frama-c-20111001+nitrogen+dfsg/tests/pdg/doc_dot.c --- frama-c-20110201+carbon+dfsg/tests/pdg/doc_dot.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/doc_dot.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,5 +1,5 @@ / run.config -* OPT: -lib-entry -main g -fct-pdg g -dot-pdg tests/pdg/doc -journal-disable + OPT: -lib-entry -main g -fct-pdg g -dot-pdg tests/pdg/doc -journal-disable -pdg-print -pdg-verbose 2 / / To build the svg file: * dot -Tsvg tests/pdg/doc.g.dot > tests/pdg/doc.g.svg diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/dpds_intra.c frama-c-20111001+nitrogen+dfsg/tests/pdg/dpds_intra.c --- frama-c-20110201+carbon+dfsg/tests/pdg/dpds_intra.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/dpds_intra.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,15 +1,15 @@ /* run.config GCC: - OPT: -fct-pdg test_struct -journal-disable - OPT: -fct-pdg test_if_simple -journal-disable - OPT: -fct-pdg test_goto_simple -journal-disable - OPT: -fct-pdg test_goto_arriere -journal-disable - OPT: -fct-pdg test_goto_else -journal-disable - OPT: -main test_ctrl_dpd_multiple -journal-disable + OPT: -fct-pdg test_struct -journal-disable -pdg-print -pdg-verbose 2 + OPT: -fct-pdg test_if_simple -journal-disable -pdg-print -pdg-verbose 2 + OPT: -fct-pdg test_goto_simple -journal-disable -pdg-print -pdg-verbose 2 + OPT: -fct-pdg test_goto_arriere -journal-disable -pdg-print -pdg-verbose 2 + OPT: -fct-pdg test_goto_else -journal-disable -pdg-print -pdg-verbose 2 + OPT: -main test_ctrl_dpd_multiple -journal-disable -pdg-print -pdg-verbose 2 => ne passe pas - OPT: -fct-pdg test_simple_loop -journal-disable - OPT: -fct-pdg main -journal-disable - OPT: -fct-pdg multiple_global_inputs -journal-disable + OPT: -fct-pdg test_simple_loop -journal-disable -pdg-print -pdg-verbose 2 + OPT: -fct-pdg main -journal-disable -pdg-print -pdg-verbose 2 + OPT: -fct-pdg multiple_global_inputs -journal-disable -pdg-print -pdg-verbose 2 / / bin/toplevel.opt -deps -main g tests/slicing/dpds_intra.c / / bin/toplevel.opt -fct-pdg test_goto_simple tests/slicing/dpds_intra.c -dot-pdg/ diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/dyn_dpds.c frama-c-20111001+nitrogen+dfsg/tests/pdg/dyn_dpds.c --- frama-c-20110201+carbon+dfsg/tests/pdg/dyn_dpds.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/dyn_dpds.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/pdg/dyn_dpds.opt CMD: tests/pdg/dyn_dpds.opt - OPT: -deps -journal-disable + OPT: -deps -journal-disable -pdg-print -pdg-verbose 2 / / diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/dyn_dpds.ml frama-c-20111001+nitrogen+dfsg/tests/pdg/dyn_dpds.ml --- frama-c-20110201+carbon+dfsg/tests/pdg/dyn_dpds.ml 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/dyn_dpds.ml 2011-10-10 08:39:09.000000000 +0000 @@ -5,12 +5,12 @@ zgrviewer tests/pdg/dyn_dpds_2.dot ; ) -let get_zones str_data (kinst, kf) = - let lval_term = !Db.Properties.Interp.lval kf kinst str_data in +let get_zones str_data (stmt, kf) = + let lval_term = !Db.Properties.Interp.lval kf stmt str_data in let lval = !Db.Properties.Interp.term_lval_to_lval ~result:None lval_term in let loc = !Db.From.find_deps_no_transitivity - (Cil_types.Kstmt kinst) + stmt (Cil.new_exp ~loc:Cil_datatype.Location.unknown (Cil_types.Lval lval)) in loc diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/globals.c frama-c-20111001+nitrogen+dfsg/tests/pdg/globals.c --- frama-c-20110201+carbon+dfsg/tests/pdg/globals.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/globals.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,8 +1,8 @@ / run.config GCC: - OPT: -val -deps -out -input -main g -journal-disable - OPT: -val -deps -out -input -main h -journal-disable - OPT: -val -deps -out -input -main f -journal-disable + OPT: -val -deps -out -input -main g -journal-disable -pdg-print -pdg-verbose 2 + OPT: -val -deps -out -input -main h -journal-disable -pdg-print -pdg-verbose 2 + OPT: -val -deps -out -input -main f -journal-disable -pdg-print -pdg-verbose 2 / struct Tstr; extern int X; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/inter_alias2.c frama-c-20111001+nitrogen+dfsg/tests/pdg/inter_alias2.c --- frama-c-20110201+carbon+dfsg/tests/pdg/inter_alias2.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/inter_alias2.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,9 +1,9 @@ / run.config * GCC: - * OPT: -val -journal-disable - * OPT: -calldeps -fct-pdg incr_ptr -journal-disable - * OPT: -calldeps -fct-pdg f1 -journal-disable - * OPT: -calldeps -fct-pdg f2 -journal-disable + * OPT: -val -journal-disable -pdg-print -pdg-verbose 2 + * OPT: -calldeps -fct-pdg incr_ptr -journal-disable -pdg-print -pdg-verbose 2 + * OPT: -calldeps -fct-pdg f1 -journal-disable -pdg-print -pdg-verbose 2 + * OPT: -calldeps -fct-pdg f2 -journal-disable -pdg-print -pdg-verbose 2 / void incr_ptr (int p) { p += 1; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/inter_alias.c frama-c-20111001+nitrogen+dfsg/tests/pdg/inter_alias.c --- frama-c-20110201+carbon+dfsg/tests/pdg/inter_alias.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/inter_alias.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config GCC: - OPT: -val -out -input -calldeps -pdg -journal-disable + OPT: -val -out -input -calldeps -pdg -journal-disable -pdg-print -pdg-verbose 2 / int G; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/loops.c frama-c-20111001+nitrogen+dfsg/tests/pdg/loops.c --- frama-c-20110201+carbon+dfsg/tests/pdg/loops.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/loops.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,14 +1,14 @@ / run.config GCC: - OPT: -lib-entry -main simple -fct-pdg simple -journal-disable - OPT: -lib-entry -main simple_with_break -fct-pdg simple_with_break -journal-disable - OPT: -lib-entry -main infinite -fct-pdg infinite -journal-disable - OPT: -lib-entry -main infinite2 -fct-pdg infinite2 -journal-disable - OPT: -lib-entry -main maybe_infinite -fct-pdg maybe_infinite -journal-disable - OPT: -lib-entry -main two_infinite_loops -fct-pdg two_infinite_loops -journal-disable - OPT: -lib-entry -main loop_with_goto -fct-pdg loop_with_goto -journal-disable - OPT: -lib-entry -main non_natural_loop -fct-pdg non_natural_loop -journal-disable - OPT: -lib-entry -main dead_code -fct-pdg dead_code -journal-disable + OPT: -lib-entry -main simple -fct-pdg simple -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main simple_with_break -fct-pdg simple_with_break -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main infinite -fct-pdg infinite -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main infinite2 -fct-pdg infinite2 -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main maybe_infinite -fct-pdg maybe_infinite -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main two_infinite_loops -fct-pdg two_infinite_loops -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main loop_with_goto -fct-pdg loop_with_goto -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main non_natural_loop -fct-pdg non_natural_loop -journal-disable -pdg-print -pdg-verbose 2 + OPT: -lib-entry -main dead_code -fct-pdg dead_code -journal-disable -pdg-print -pdg-verbose 2 diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/multiple_calls.c frama-c-20111001+nitrogen+dfsg/tests/pdg/multiple_calls.c --- frama-c-20110201+carbon+dfsg/tests/pdg/multiple_calls.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/multiple_calls.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,7 +1,7 @@ /* run.config GCC: - OPT: -inout -deps -main appel_ptr_fct -fct-pdg appel_ptr_fct -journal-disable - OPT: -inout -deps -main appel_ptr_fct_bis -fct-pdg appel_ptr_fct_bis -journal-disable + OPT: -inout -deps -main appel_ptr_fct -fct-pdg appel_ptr_fct -journal-disable -pdg-print -pdg-verbose 2 + OPT: -inout -deps -main appel_ptr_fct_bis -fct-pdg appel_ptr_fct_bis -journal-disable -pdg-print -pdg-verbose 2 / extern int G1, G2, G3, G4; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/no_body.c frama-c-20111001+nitrogen+dfsg/tests/pdg/no_body.c --- frama-c-20110201+carbon+dfsg/tests/pdg/no_body.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/no_body.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config * GCC: -* OPT: -fct-pdg main -inout -journal-disable +* OPT: -fct-pdg main -inout -journal-disable -pdg-print -pdg-verbose 2 / / * ledit bin/toplevel.top tests/slicing/no_body.c -fct-pdg main diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/pb_infinite_loop.c frama-c-20111001+nitrogen+dfsg/tests/pdg/pb_infinite_loop.c --- frama-c-20110201+carbon+dfsg/tests/pdg/pb_infinite_loop.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/pb_infinite_loop.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,8 +1,8 @@ /* run.config GCC: - OPT: -main test_infinite_loop -fct-pdg test_infinite_loop -journal-disable - OPT: -main test_infinite_loop_2 -fct-pdg test_infinite_loop_2 -journal-disable - OPT: -main test_exit -fct-pdg test_exit -journal-disable + OPT: -main test_infinite_loop -fct-pdg test_infinite_loop -journal-disable -pdg-print -pdg-verbose 2 + OPT: -main test_infinite_loop_2 -fct-pdg test_infinite_loop_2 -journal-disable -pdg-print -pdg-verbose 2 + OPT: -main test_exit -fct-pdg test_exit -journal-disable -pdg-print -pdg-verbose 2 / / This test is a problem at the moment because the postdominators are Top diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/sets.c frama-c-20111001+nitrogen+dfsg/tests/pdg/sets.c --- frama-c-20110201+carbon+dfsg/tests/pdg/sets.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/sets.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,7 +1,7 @@ /* run.config EXECNOW: make -s tests/pdg/sets.opt CMD: tests/pdg/sets.opt - OPT: -lib-entry -main f -pdg -inout -journal-disable + OPT: -lib-entry -main f -pdg -inout -journal-disable -pdg-print -pdg-verbose 2 / int b, c, x, y, z, t; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/sets.ml frama-c-20111001+nitrogen+dfsg/tests/pdg/sets.ml --- frama-c-20110201+carbon+dfsg/tests/pdg/sets.ml 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/sets.ml 2011-10-10 08:39:09.000000000 +0000 @@ -2,8 +2,8 @@ open Cil_types;; let pp_nodes msg nodes = - Cil.log "%s" msg ; - List.iter (fun n -> Cil.log "%a" (!Pdg.pretty_node false) n) nodes;; + Kernel.result "%s" msg ; + List.iter (fun n -> Kernel.result "%a" (!Pdg.pretty_node false) n) nodes;; exception Find of varinfo;; @@ -30,8 +30,11 @@ v in - let y_zone = Locations.valid_enumerate_bits (Locations.loc_of_varinfo y) in - + let y_zone = + Locations.valid_enumerate_bits + ~for_writing:false + (Locations.loc_of_varinfo y) + in let y_at_11_nodes, undef = ( y=5 ) !Pdg.find_location_nodes_at_stmt pdg (fst (Kernel_function.find_from_sid 11)) ~before:false y_zone diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/simple_call.c frama-c-20111001+nitrogen+dfsg/tests/pdg/simple_call.c --- frama-c-20110201+carbon+dfsg/tests/pdg/simple_call.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/simple_call.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,9 +1,9 @@ / run.config GCC: - OPT: -fct-pdg main -journal-disable - OPT: -main call_in_loop -fct-pdg call_in_loop -journal-disable - OPT: -main call_mix_G1_G2 -fct-pdg call_mix_G1_G2 -journal-disable - OPT: -main call_multiple_global_outputs -fct-pdg call_multiple_global_outputs -journal-disable + OPT: -fct-pdg main -journal-disable -pdg-print -pdg-verbose 2 + OPT: -main call_in_loop -fct-pdg call_in_loop -journal-disable -pdg-print -pdg-verbose 2 + OPT: -main call_mix_G1_G2 -fct-pdg call_mix_G1_G2 -journal-disable -pdg-print -pdg-verbose 2 + OPT: -main call_multiple_global_outputs -fct-pdg call_multiple_global_outputs -journal-disable -pdg-print -pdg-verbose 2 / extern int G, G1, G2; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/simple_intra_slice.c frama-c-20111001+nitrogen+dfsg/tests/pdg/simple_intra_slice.c --- frama-c-20110201+carbon+dfsg/tests/pdg/simple_intra_slice.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/simple_intra_slice.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config GCC: - OPT: -pdg -journal-disable + OPT: -pdg -journal-disable -pdg-print -pdg-verbose 2 / / test con�u initialement comme test pour le slicing / int Unknown; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/top_pdg_input.c frama-c-20111001+nitrogen+dfsg/tests/pdg/top_pdg_input.c --- frama-c-20110201+carbon+dfsg/tests/pdg/top_pdg_input.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/top_pdg_input.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -val -out -input -deps -pdg -journal-disable + OPT: -val -out -input -deps -pdg -journal-disable -pdg-print -pdg-verbose 2 */ int ** top_input() ; diff -Nru frama-c-20110201+carbon+dfsg/tests/pdg/variadic.c frama-c-20111001+nitrogen+dfsg/tests/pdg/variadic.c --- frama-c-20110201+carbon+dfsg/tests/pdg/variadic.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/pdg/variadic.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ /* run.config * GCC: -* OPT: -pdg -journal-disable +* OPT: -pdg -journal-disable -pdg-print -pdg-verbose 2 / #include <stdarg.h> @@ -17,16 +17,18 @@ return s; } +int lib_f (int n, ...); + int f1 (int a) { - return f (1, a); + return lib_f (1, a); } int f2 (int a, int b) { - return f (2, a, b); + return lib_f (2, a, b); } int f3 (int a, int b, int c) { - return f (3, a, b, c); + return lib_f (3, a, b, c); } int main (void) { diff -Nru frama-c-20110201+carbon+dfsg/tests/rte/assign7.c frama-c-20111001+nitrogen+dfsg/tests/rte/assign7.c --- frama-c-20110201+carbon+dfsg/tests/rte/assign7.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/rte/assign7.c 2011-10-10 08:38:51.000000000 +0000 @@ -0,0 +1,33 @@ +/ run.config + OPT: -rte -rte-print -rte-no-all -rte-precond -journal-disable +/ + +//@ assigns p \from \union((char)p,q); +extern void f(int p, int* q); + +//@ assigns p \from \union(p, \union(r,q)); +extern void ff(int* p, int* q, int* r); + +//@ assigns p \from \inter((char)p,q); +extern void h(int* p, int* q); + +//@ assigns \union(p,q); +extern void g(int* p, int* q); + +/@ assigns \at(p,Post), \at(p,Pre), p ; + / +extern void gg(int p); + +int X, Y ; +//@ assigns \union(X, Y) ; +void hh(); + +int main() { + int x,y,z; + f(&x,&y); + ff(&x,&y,&z); + g(&x,&y); + h(&x,&y); + gg(&x); + hh(); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/rte/bts0567.c frama-c-20111001+nitrogen+dfsg/tests/rte/bts0567.c --- frama-c-20110201+carbon+dfsg/tests/rte/bts0567.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/rte/bts0567.c 2011-10-10 08:38:51.000000000 +0000 @@ -1,5 +1,5 @@ /* run.config - OPT: -rte -print -journal-disable + OPT: -rte -rte-precond -print -journal-disable / int tab [2] ; diff -Nru frama-c-20110201+carbon+dfsg/tests/rte/bts0576.c frama-c-20111001+nitrogen+dfsg/tests/rte/bts0576.c --- frama-c-20110201+carbon+dfsg/tests/rte/bts0576.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/rte/bts0576.c 2011-10-10 08:38:51.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -rte -rte-print -journal-disable + OPT: -rte -rte-print -rte-precond -journal-disable / typedef double typetab[2]; diff -Nru frama-c-20110201+carbon+dfsg/tests/rte/bts0580.i frama-c-20111001+nitrogen+dfsg/tests/rte/bts0580.i --- frama-c-20110201+carbon+dfsg/tests/rte/bts0580.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/rte/bts0580.i 2011-10-10 08:38:51.000000000 +0000 @@ -0,0 +1,10 @@ +/ run.config + OPT: -rte -rte-no-all -rte-mem -print -journal-disable +/ +struct ArrayStruct { + int data[10]; +} buff; + +int main (int i) { + return buff.data[i] ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/rte/castoncall.c frama-c-20111001+nitrogen+dfsg/tests/rte/castoncall.c --- frama-c-20110201+carbon+dfsg/tests/rte/castoncall.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/rte/castoncall.c 2011-10-10 08:38:51.000000000 +0000 @@ -0,0 +1,26 @@ +/ run.config + OPT: -rte -rte-precond -rte-print -journal-disable + OPT: -rte -rte-precond -no-collapse-call-cast -rte-print -journal-disable +/ + +/@ + ensures (\result == a) || (\result == b); + assigns \result \from a,b; + / +int nondet(int a, int b); + +/@ + ensures (\result == a) || (\result == b); + assigns \result \from a,b; + / +void nondet_ptr(void a, void b) { + return (void) nondet((int)a, (int)b); +} + +//@ ensures \result == 1; +int f(); + +void g() { + char c = f(); + return; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/rte/fptr_assert.c frama-c-20111001+nitrogen+dfsg/tests/rte/fptr_assert.c --- frama-c-20110201+carbon+dfsg/tests/rte/fptr_assert.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/rte/fptr_assert.c 2011-10-10 08:38:51.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -rte -rte-print -journal-disable + OPT: -rte -rte-precond -rte-print -journal-disable / typedef int (fptr)(int); diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/basic.i frama-c-20111001+nitrogen+dfsg/tests/saveload/basic.i --- frama-c-20110201+carbon+dfsg/tests/saveload/basic.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/basic.i 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,23 @@ +/* run.config + EXECNOW: make -s ./tests/saveload/basic.opt + EXECNOW: LOG basic_sav.res LOG basic_sav.err BIN basic.sav ./tests/saveload/basic.opt -val -out -input -deps ./tests/saveload/basic.i -save ./tests/saveload/result/basic.sav > ./tests/saveload/result/basic_sav.res 2> ./tests/saveload/result/basic_sav.err + EXECNOW: LOG basic_sav.1.res LOG basic_sav.1.err BIN basic.1.sav ./bin/toplevel.opt -save ./tests/saveload/result/basic.1.sav ./tests/saveload/basic.i -val -out -input -deps > ./tests/saveload/result/basic_sav.1.res 2> ./tests/saveload/result/basic_sav.1.err + OPT: -load ./tests/saveload/result/basic.sav -val -out -input -deps -journal-disable + CMD: ./tests/saveload/basic.opt + OPT: -load ./tests/saveload/result/basic.1.sav -val -out -input -deps -journal-disable -print + OPT: -load ./tests/saveload/result/basic.1.sav -val -out -input -deps -journal-disable + EXECNOW: LOG status_sav.res LOG status_sav.err BIN status.sav ./bin/toplevel.byte -load-script tests/saveload/status.ml -save ./tests/saveload/result/status.sav ./tests/saveload/basic.i > ./tests/saveload/result/status_sav.res 2> ./tests/saveload/result/status_sav.err + CMD: ./bin/toplevel.byte + OPT: -load-script tests/saveload/status.ml -load ./tests/saveload/result/status.sav +/ + +int main() { + int i, j; + + i = 10; + /@ assert (i == 10); / + while(i--); + j = 5; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/basic.ml frama-c-20111001+nitrogen+dfsg/tests/saveload/basic.ml --- frama-c-20110201+carbon+dfsg/tests/saveload/basic.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/basic.ml 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,11 @@ +module StateA = + State_builder.Ref + (Datatype.Int) + (struct + let name = "Project.Test.StateA" + let dependencies = [] + let kind = `Internal + let default () = 0 + end) + +let () = StateA.set 10 diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/deps.i frama-c-20111001+nitrogen+dfsg/tests/saveload/deps.i --- frama-c-20110201+carbon+dfsg/tests/saveload/deps.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/deps.i 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,22 @@ +/ run.config + EXECNOW: make -s ./tests/saveload/deps_A.opt ./tests/saveload/deps_B.opt ./tests/saveload/deps_C.opt ./tests/saveload/deps_D.opt + EXECNOW: LOG deps_sav.res LOG deps_sav.err BIN deps.sav ./tests/saveload/deps_A.opt -val -out -input -deps ./tests/saveload/deps.i -save ./tests/saveload/result/deps.sav > ./tests/saveload/result/deps_sav.res 2> ./tests/saveload/result/deps_sav.err + CMD: ./tests/saveload/deps_A.opt + OPT: -load ./tests/saveload/result/deps.sav -val -out -input -deps + CMD: ./tests/saveload/deps_B.opt + OPT: -load ./tests/saveload/result/deps.sav -val -out -input -deps + CMD: ./tests/saveload/deps_C.opt + OPT: -load ./tests/saveload/result/deps.sav -val -out -input -deps + CMD: ./tests/saveload/deps_D.opt + OPT: -load ./tests/saveload/result/deps.sav -val -out -input -deps +/ + +int main() { + int i, j; + + i = 10; + while(i--); + j = 5; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/load_one.i frama-c-20111001+nitrogen+dfsg/tests/saveload/load_one.i --- frama-c-20110201+carbon+dfsg/tests/saveload/load_one.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/load_one.i 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,29 @@ +/ run.config_no_native_dynlink + CMD: bin/toplevel.byte + OPT: -load-script tests/saveload/load_one.ml +/ +/ run.config + OPT: -load-script tests/saveload/load_one.ml +/ + +int G; + +int f (int x, int y) { + G = y; + return x; +} + +int main (void) { + int a = 1; + int b = 1; + + /@ assert a == 1; / + + f (0, 0); / this call is useless : should be removed / + a = f (a, b); / the result of this call is useless / + a = f (G + 1, b); + + G = 0; / don't use the G computed by f / + + return a; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/multi_project.i frama-c-20111001+nitrogen+dfsg/tests/saveload/multi_project.i --- frama-c-20110201+carbon+dfsg/tests/saveload/multi_project.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/multi_project.i 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,17 @@ +/ run.config + EXECNOW: BIN multi_project.sav LOG multi_project_sav.res LOG multi_project_sav.err ./bin/toplevel.opt -save ./tests/saveload/result/multi_project.sav -semantic-const-folding ./tests/saveload/multi_project.i > tests/saveload/result/multi_project_sav.res 2> tests/saveload/result/multi_project_sav.err + EXECNOW: make -s ./tests/saveload/multi_project.opt + OPT: -load ./tests/saveload/result/multi_project.sav -journal-disable + CMD: ./tests/saveload/multi_project.opt -val + OPT: +/ +int f(int x) { + return x + x; +} + +int main() { + int x = 2; + int y = f(x); + /@ assert y == 4; / + return x y; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/multi_project.ml frama-c-20111001+nitrogen+dfsg/tests/saveload/multi_project.ml --- frama-c-20110201+carbon+dfsg/tests/saveload/multi_project.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/multi_project.ml 2011-10-10 08:39:04.000000000 +0000 @@ -2,7 +2,7 @@ Kernel.log "Checking %S@." name; Project.on (Project.from_unique_name name) - (fun () -> assert (test (Parameters.Files.get ()) [])) () + (fun () -> assert (test (Kernel.Files.get ()) [])) () let main () = ignore (Project.create_by_copy "foo"); @@ -11,7 +11,7 @@ check "foo" (<>); check "foobar" (=); check "default" (<>); - Parameters.Files.set []; + Kernel.Files.set []; Project.load_all "foo.sav"; Extlib.safe_remove "foo.sav"; ignore (Project.create_by_copy "bar"); diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/segfault_datatypes.i frama-c-20111001+nitrogen+dfsg/tests/saveload/segfault_datatypes.i --- frama-c-20110201+carbon+dfsg/tests/saveload/segfault_datatypes.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/segfault_datatypes.i 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,17 @@ +/* run.config + EXECNOW: make -s ./tests/saveload/segfault_datatypes_A.opt + EXECNOW: make -s ./tests/saveload/segfault_datatypes_B.opt + EXECNOW: LOG segfault_datatypes_sav.res LOG segfault_datatypes_sav.err BIN segfault_datatypes.sav ./tests/saveload/segfault_datatypes_A.opt -val -out -input -deps ./tests/saveload/segfault_datatypes.i -save ./tests/saveload/result/segfault_datatypes.sav > ./tests/saveload/result/segfault_datatypes_sav.res 2> ./tests/saveload/result/segfault_datatypes_sav.err + CMD: ./tests/saveload/segfault_datatypes_B.opt + OPT: -load ./tests/saveload/result/segfault_datatypes.sav -val -out -input -deps -journal-disable +/ + +int main() { + int i, j; + + i = 10; + while(i--); + j = 5; + + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/size.ml frama-c-20111001+nitrogen+dfsg/tests/saveload/size.ml --- frama-c-20110201+carbon+dfsg/tests/saveload/size.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/size.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -module StateA = - State_builder.Ref - (Datatype.Int) - (struct - let name = "Project.Test.StateA" - let dependencies = [] - let kind = `Internal - let default () = 0 - end) - -let () = StateA.set 10 diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/sparecode.i frama-c-20111001+nitrogen+dfsg/tests/saveload/sparecode.i --- frama-c-20110201+carbon+dfsg/tests/saveload/sparecode.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/sparecode.i 2011-10-10 08:39:04.000000000 +0000 @@ -0,0 +1,23 @@ +/ run.config + EXECNOW: BIN sparecode.sav LOG sparecode_sav.res LOG sparecode_sav.err ./bin/toplevel.opt -slicing-level 2 -slice-return main -save ./tests/saveload/result/sparecode.sav tests/saveload/sparecode.i -then-on 'Slicing export' -print > tests/saveload/result/sparecode_sav.res 2> tests/saveload/result/sparecode_sav.err + OPT: -load ./tests/saveload/result/sparecode.sav +/ +int G; + +int f (int x, int y) { + G = y; + return x; +} + +int main (void) { + int a = 1; + int b = 1; + + f (0, 0); / this call is useless : should be removed / + a = f (a, b); / the result of this call is useless / + a = f (G + 1, b); + + G = 0; / don't use the G computed by f / + + return a; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/saveload/status.ml frama-c-20111001+nitrogen+dfsg/tests/saveload/status.ml --- frama-c-20110201+carbon+dfsg/tests/saveload/status.ml 2011-02-07 13:41:50.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/saveload/status.ml 2011-10-10 08:39:04.000000000 +0000 @@ -1,41 +1,23 @@ open Cil_types -module Self = - State_builder.False_ref - (struct - let name = "Test" - let dependencies = [] - let kind = `Correctness - end) - -module Up = - Properties_status.Make_updater - (struct let name = "Test" let emitter = Self.self end) - -module Blob = - State_builder.False_ref - (struct - let name = "Blob" - let dependencies = [] - let kind = `Correctness - end) +let emitter = Emitter.create "Test" ~correctness:[] ~tuning:[] let main () = Ast.compute (); Annotations.iter (fun s _ (ca, _) -> - let s', kf = Kernel_function.find_from_sid s.Cil_types.sid in - assert (Cil_datatype.Stmt.equal s s'); + let kf = Kernel_function.find_englobing_kf s in let ps = Property.ip_of_code_annot kf s (Annotations.get_code_annotation ca) in List.iter (fun p -> - Up.set + Property_status.emit + emitter p - [ Property.ip_blob Blob.self ] - (Checked { emitter = "Test emitter"; valid = Maybe }); - Format.printf "%a@." Properties_status.pretty_all p) + ~hyps:[ Property.ip_other "Blob" None Kglobal ] + Property_status.Dont_know; + Format.printf "%a@." Property_status.pretty (Property_status.get p)) ps) let () = Db.Main.extend main diff -Nru frama-c-20110201+carbon+dfsg/tests/scope/bts383.c frama-c-20111001+nitrogen+dfsg/tests/scope/bts383.c --- frama-c-20110201+carbon+dfsg/tests/scope/bts383.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/scope/bts383.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -val -print -journal-disable -scope-verbose 1 -scope-debug 1 + OPT: -val -print -journal-disable -scope-verbose 1 -scope-debug 1 -remove-redundant-alarms / / echo '!Db.Scope.check_asserts();;' \ diff -Nru frama-c-20110201+carbon+dfsg/tests/scope/bts971.c frama-c-20111001+nitrogen+dfsg/tests/scope/bts971.c --- frama-c-20110201+carbon+dfsg/tests/scope/bts971.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/scope/bts971.c 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,32 @@ +/* run.config + OPT: -journal-disable -load-script tests/scope/bts971.ml +/ + + +volatile foo; +int v; + +void f1 () { + v += 1; +} + +void f () { + f1 (); +} + +void g1 () { + v += 2; + v += 3; +} + +void g () { + g1 (); +} + +void main (int c) { + v += 0; + while (c) { + if (foo) {f ();}; + if (foo) {g ();}; + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/scope/bts971.ml frama-c-20111001+nitrogen+dfsg/tests/scope/bts971.ml --- frama-c-20110201+carbon+dfsg/tests/scope/bts971.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/scope/bts971.ml 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,55 @@ + +let find_pp kf_name = + let kf = Globals.Functions.find_by_name kf_name in + let stmt = Kernel_function.find_first_stmt kf in + Format.printf "Current program point = first one in function '%s'@\n" + kf_name; + stmt, kf +;; + +let compute_and_print pp str_data = + let stmt, kf = pp in + let lval_term = !Db.Properties.Interp.lval kf stmt str_data in + let lval = !Db.Properties.Interp.term_lval_to_lval ~result:None lval_term in + let defs = !Db.Scope.get_defs kf stmt lval in + Format.printf " @[<v 2>Defs for (%s) at current program point=@[<v 2>@." + str_data; + let _ = match defs with + | None -> Format.printf "computation problem.@." + | Some (defs, _undef) when Cil_datatype.Stmt.Set.is_empty defs -> + Format.printf "no Defs found@." + | Some (defs, _undef) -> + Cil_datatype.Stmt.Set.iter + (fun s -> + Format.printf "%a: %a@\n" Cil.d_loc (Cil_datatype.Stmt.loc s) + Cil_datatype.Stmt.pretty s) defs + in Format.printf "@]@]@.@." +;; + +let tests () = + let pp = find_pp "f1" in compute_and_print pp "v"; + let stmt, kf as pp = find_pp "g1" in compute_and_print pp "v"; + let stmt = match stmt.Cil_types.succs with s::_ -> s | _ -> assert false in + Format.printf "Current program point = 2d one in function '%s'@\n" "g1"; + compute_and_print (stmt, kf) "v"; + let pp = find_pp "f" in compute_and_print pp "v" + +let main _ = + Format.printf "=== Tests for Scope.Defs@."; + Ast.compute (); + Dynamic.Parameter.Bool.set "-val-show-progress" false ; + Dynamic.Parameter.Int.set "-value-verbose" 0 ; + Dynamic.Parameter.Int.set "-from-verbose" 0 ; + Dynamic.Parameter.Int.set "-pdg-verbose" 0 ; + + Format.printf "--- Intraprocedural mode (-scope-no-defs-interproc)@."; + Dynamic.Parameter.Bool.set "-scope-defs-interproc" false ; + tests (); + + Format.printf "--- Interprocedural mode (-scope-defs-interproc)@."; + Dynamic.Parameter.Bool.set "-scope-defs-interproc" true ; + tests () +;; + +let _ = Db.Main.extend main + diff -Nru frama-c-20110201+carbon+dfsg/tests/scope/zones.ml frama-c-20111001+nitrogen+dfsg/tests/scope/zones.ml --- frama-c-20110201+carbon+dfsg/tests/scope/zones.ml 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/scope/zones.ml 2011-10-10 08:39:09.000000000 +0000 @@ -22,7 +22,7 @@ let find_sid sid = let stmt, kf = Kernel_function.find_from_sid sid in Format.printf "Current program point = before stmt %d in function %a@\n" - sid Kernel_function.pretty_name kf; + sid Kernel_function.pretty kf; stmt, kf ;; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts0184.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts0184.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts0184.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts0184.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ /* run.config - OPT: -slice-pragma x -journal-disable + OPT: -check -slice-pragma x -journal-disable **/ int x(int y, int z) { diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts0190.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts0190.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts0190.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts0190.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ /* run.config -OPT: -slice-rd y +OPT: -check -slice-rd y / int x(int y, int z) diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts0950_annot.i frama-c-20111001+nitrogen+dfsg/tests/slicing/bts0950_annot.i --- frama-c-20110201+carbon+dfsg/tests/slicing/bts0950_annot.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts0950_annot.i 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + OPT: -val -slice-value a -then-on "Slicing export" -print + / +/@ requires \valid(dest); / +extern void cpy(int dest, const int src); + +void cpy(int region1, const int* region2) { + (region1) = region2; +} + +int a=1, b=2; + +void main() { + cpy(&a,&b); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts179.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts179.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts179.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts179.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ /* run.config - OPT: -slice-return main -slice-print -journal-disable - OPT: -slice-pragma main -slice-print -journal-disable - OPT: -sparecode-analysis -journal-disable + OPT: -check -slice-return main -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-pragma main -journal-disable -then-on 'Slicing export' -print + OPT: -check -sparecode-analysis -journal-disable / struct {int a; int ab; int b; int c ; int d;} S; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts283.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts283.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts283.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts283.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -slice-print -slice-return main -slice-undef-functions -journal-disable + OPT: -check -slice-return main -slice-undef-functions -journal-disable -then-on 'Slicing export' -print / int x,y,z; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts326.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts326.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts326.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts326.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -calldeps -slice-print -slice-return main -journal-disable + OPT: -check -calldeps -slice-return main -journal-disable -then-on 'Slicing export' -print / / Problem : f(1) should be sliced out. See BTS#326 / int t[2] ; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts335b.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts335b.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts335b.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts335b.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -slice-return main -calldeps -slicing-level 3 -slice-print -slicing-verbose 2 -slicing-debug 1 -journal-disable + OPT: -check -slice-return main -calldeps -slicing-level 3 -slicing-verbose 2 -journal-disable -then-on 'Slicing export' -print / int X, Y; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts335.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts335.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts335.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts335.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,9 +1,9 @@ / run.config - OPT: -slice-pragma g -calldeps -slicing-level 3 + OPT: -check -slice-pragma g -calldeps -slicing-level 3 / / -bin/toplevel.opt -slice-pragma g -calldeps -slicing-level 3 tests/slicing/bts335.c -debug 2 +bin/toplevel.opt -check -slice-pragma g -calldeps -slicing-level 3 tests/slicing/bts335.c -debug 2 bin/toplevel.opt -pdg-debug -pdg -pdg-debug "-dot-pdg bts335" tests/slicing/bts335.c / int T[2] = {0, 0}; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts336.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts336.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts336.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts336.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,8 +1,8 @@ / run.config - OPT: -slice-return main -slice-print -calldeps -journal-disable - OPT: -main main2 -slice-return main2 -slice-print -calldeps -journal-disable - OPT: -main main3 -slice-return main3 -slice-print -journal-disable - OPT: -main main3 -slice-return main3 -slice-print -calldeps -journal-disable + OPT: -check -slice-return main -calldeps -journal-disable -then-on 'Slicing export' -print + OPT: -check -main main2 -slice-return main2 -calldeps -journal-disable -then-on 'Slicing export' -print + OPT: -check -main main3 -slice-return main3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main main3 -slice-return main3 -calldeps -journal-disable -then-on 'Slicing export' -print / //-------------------------------------- // something to do to have better results... diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts341.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts341.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts341.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts341.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -slice-print -slice-assert main -journal-disable + OPT: -check -slice-assert main -journal-disable -then-on 'Slicing export' -print / int main (int c) { if (c) diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts344.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts344.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts344.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts344.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,6 +1,6 @@ / run.config - OPT: -slice-print -slice-return main -journal-disable - OPT: -slice-print -slice-return main_bis -main main_bis -journal-disable + OPT: -check -slice-return main -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return main_bis -main main_bis -journal-disable -then-on 'Slicing export' -print / int X, Y ; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts345.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts345.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts345.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts345.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,9 +1,9 @@ / run.config - OPT: -slice-print -slice-return call_top -main call_top -journal-disable - OPT: -slice-print -slice-return top -main top -journal-disable - OPT: -slice-print -slice-return top -main call_top -journal-disable - OPT: -slice-return called_by_top -main top -journal-disable - OPT: -slice-return called_by_top -main call_top -journal-disable + OPT: -check -slice-return call_top -main call_top -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return top -main top -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return top -main call_top -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return called_by_top -main top -journal-disable + OPT: -check -slice-return called_by_top -main call_top -journal-disable / int called_indirectly_by_top (int x) { diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts709.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts709.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts709.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts709.c 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,56 @@ +/ run.config + OPT: -check -slice-pragma func -no-unicode -journal-disable -then-on 'Slicing export' -print + / + +int inputsOf_testcase_func (); +int inp1, var1,var2; + +void func( void ) +{ + if ( 1 == inp1 ) + { + // Block-1 + var1 = 1 ; + var2 = 1 ; + } + else + { + if ( 2== inp1 ) + { + // Block-2 + var1 = 2 ; + var2 = 2 ; + } + else + { + // Block-3 + if ( 3== inp1 ) + { + var1 = 3; + var2 = 3 ; + } + } + } + + //@slice pragma stmt; + 65 != var2 ? assert ( 5 != var1):1; +} + + +int main( ) { + + + int _noOfIter_ = 0; + for (_noOfIter_=0; _noOfIter_ < 1; _noOfIter_++ ) { + inputsOf_testcase_func ( ); + func (); + } +} + +int inputsOf_testcase_func () +{ + int nondet_int ( ); + inp1 = nondet_int ( ); + var1 = nondet_int ( ); // This required line is getting knocked off + var2 = nondet_int ( ); // This required line is getting knocked off +} diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts808.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts808.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts808.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts808.c 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,22 @@ +/ run.config +* OPT: -check -slice-return main -journal-disable -then-on 'Slicing export' -print +/ + +int f0 (void) { + int i = 0; + int x; + if (i) { x = 1; L: x++; } + else { x = 0; goto L; } + return x; +} +int f1 (void) { + int i = 1; + int x; + if (i) { x = 1; goto L; } + else { x = 0; L: x++; } + return x; +} + +int main (int n) { + return f0 () + f1 (); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/bts827.c frama-c-20111001+nitrogen+dfsg/tests/slicing/bts827.c --- frama-c-20110201+carbon+dfsg/tests/slicing/bts827.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/bts827.c 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,19 @@ +/ run.config + OPT: -check -slice-return main -journal-disable -then-on 'Slicing export' -print +/ + +/ The problem was a mix-up between f outputs and retrun value. / + +int G; + +int f (void) { + G = 3; + return 5; +} + +int main (void) { + G = 1; + G += f (); + return G; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/call_accuracy.c frama-c-20111001+nitrogen+dfsg/tests/slicing/call_accuracy.c --- frama-c-20110201+carbon+dfsg/tests/slicing/call_accuracy.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/call_accuracy.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -calldeps -slice-return main -slicing-level 3 -slice-print -journal-disable + OPT: -check -calldeps -slice-return main -slicing-level 3 -journal-disable -then-on 'Slicing export' -print / int f_cond (int c, int a, int b) { ++a; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/call_demo.c frama-c-20111001+nitrogen+dfsg/tests/slicing/call_demo.c --- frama-c-20110201+carbon+dfsg/tests/slicing/call_demo.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/call_demo.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,6 @@ / run.config - GCC: - OPT: -slice-print -slice-calls call1 -journal-disable - OPT: -slice-print -slice-calls call2 -journal-disable + OPT: -check -slice-calls call1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls call2 -journal-disable -then-on 'Slicing export' -print / //@ assigns \result \from v; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/callwise.c frama-c-20111001+nitrogen+dfsg/tests/slicing/callwise.c --- frama-c-20110201+carbon+dfsg/tests/slicing/callwise.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/callwise.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,6 +1,5 @@ / run.config - GCC: - OPT: -calldeps -slice-return main -slicing-level 2 -slice-print -journal-disable + OPT: -check -calldeps -slice-return main -slicing-level 2 -journal-disable -then-on 'Slicing export' -print / int a = 1, b = 1, c = 1, d = 1, p; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/combine.c frama-c-20111001+nitrogen+dfsg/tests/slicing/combine.c --- frama-c-20110201+carbon+dfsg/tests/slicing/combine.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/combine.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ /* run.config EXECNOW: make -s tests/slicing/combine.opt CMD: tests/slicing/combine.opt - OPT: -deps -journal-disable + OPT: -check -deps -journal-disable / //@ assigns \result \from x; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/csmith.c frama-c-20111001+nitrogen+dfsg/tests/slicing/csmith.c --- frama-c-20110201+carbon+dfsg/tests/slicing/csmith.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/csmith.c 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,222 @@ +/ run.config + OPT: -slice-return main -journal-disable -then-on 'Slicing export' -print +COMMENT: TODO add -check to the command, but it fails at the moment... + **/ + + +int G1; +void f1 (int c) { + for (int x = 0; x < 10; x++) { + G1 = 3; + if (G1) break; + return; + } +} + +int G1b; +void f1b (void) { +W: { { + G1b = 3; + if (G1b) goto B; + return; + } + goto W; + } +B: ; +} + +int G2; +void f2(void) { + while (1) { + G2 = 3; + if (G2) break; + } +} + +int bts181 (int c) { + int x = 0, y = 0; + if (c) { + x = 1; + if (x>0) + y = 3; + } + return y; +} +int bts181b (int c) { + int x = 0, y = 0; + if (c) { + x = 1; + if (x>0) + y = 3; + else + y = 4; + } + return y; +} + +int bts807 (void) { + int g = 0; + int b = 7; + int a = 2; + if ((( a || 42) && b)) { + while (1) { + g = 21; + return g; + } + } + return g; +} + +int bts809 (void) { + int x; + while (1) { + x = 10; + goto L; + while (x) { +L: return x; + } + } +} + +// TODO: see COMMENT above. +int bts879 (int c) { + int g = 0; + int p = c ? 0 : 10; + + if (p || (g && G1) ) { + return 1; + } + return 0; +} + +// This one looks similar to the previous one, but without the block, +// Cil doesn't generate a goto from the then branch to the else branch... +int bts879b (int c) { + int g = 0; + int p = c ? 0 : 10; + + if (p || (g && G1) ) + return 1; + + return 0; +} + +int one_time_loop_with_break () { + int x; + while (1) { + x = 3; + if (x > 0) break; + x++; + } + return x; +} + +/* TODO: find an example... I didn't manage to build one. +int one_time_loop_with_continue () { + int x = 0; + while (1) { + x++; + if (x == 2) break; + if (x == 1) continue; + } + return x; +} +/ + +int bts899 (void ) { + int vrai = 1; + int x = 254; + for (int i = 17; (i != (-9)); i--) { + if (! i) { + if (vrai) + continue; + continue; // unreachable but disturb ctrl dependencies... + } + x ++; + } + return x; +} + +int bts906 (void) { + int x = 0; + int i = 2; + while (i >= 0) { + while (1) { + if (i) + goto B; + else { + x ++; + return x; + if (x) + goto B; + } + } +B : i --; + } + return 0; +} + +int bts906b (void) { + int x = 0; + int i = 2; + while (i >= 0) { + while (1) { + if (i) + goto B; + else { + x ++; + return x; + x++; + if (x) + goto B; + } + } +B : i --; + } + return 0; +} + +int bts963 (void) { + int x = 0; + int i; +L: i = 0; + while (i < 10) { + x++; + if (x < 3) goto L; + else return x; + } + return x; +} + +int bts963b (void) { + int x = 0; + int i; +L: i = 0; + while (i < 10) { + x++; + if (x < 3) goto L; + else return x; + i++; + } + return x; +} + +int main (int n) { + int x = 0; + f1 (n); x += G1; + f1b (); x += G1b; + f2 (); x += G2; + x += bts181 (n); + x += bts181b (n); + x += bts807 (); + x += bts809 (); + x += bts879 (n); + x += bts879b (n); + x += bts899 (); + x += bts906 (); + x += bts906b (); + x += bts963 (); + x += bts963b (); + return x; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/ex_spec_interproc.c frama-c-20111001+nitrogen+dfsg/tests/slicing/ex_spec_interproc.c --- frama-c-20110201+carbon+dfsg/tests/slicing/ex_spec_interproc.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/ex_spec_interproc.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/ex_spec_interproc.opt CMD: tests/slicing/ex_spec_interproc.opt - OPT: -deps -journal-disable + OPT: -check -deps -journal-disable / int X, Y; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/ex_spec_interproc.ml frama-c-20111001+nitrogen+dfsg/tests/slicing/ex_spec_interproc.ml --- frama-c-20110201+carbon+dfsg/tests/slicing/ex_spec_interproc.ml 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/ex_spec_interproc.ml 2011-10-10 08:38:44.000000000 +0000 @@ -75,7 +75,7 @@ ( VP: initial value of 34 does not refer to d++ (was 30) 9 corresponds to d++. old ki 34 corresponds to return(X), new ki 13 ) print_stmt project kf_f; - let ki,_ = Kernel_function.find_from_sid 10(34) in ( d++ ) + let ki = get_stmt 10(34) in ( d++ ) let select = select_data_before_stmt "a" ki project kf_f in !S.Request.add_slice_selection_internal project ff_f select; print_requests project; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/filter.c frama-c-20111001+nitrogen+dfsg/tests/slicing/filter.c --- frama-c-20110201+carbon+dfsg/tests/slicing/filter.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/filter.c 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,45 @@ +/ run.config + OPT: -check -slice-return main -journal-disable -then-on 'Slicing export' -print + **/ + +/* TESTS: this is about [filter] optimisations since sometimes, + * slicing results are ok, but the generated new project is not correct. / + +int T[10]; + +/ When removing branches, one should take care about local variables. / +int bts806 () { + int c = 0; + int x = 0; + + if (c) { + int y; + { y = x+1; + x = y; + } + } + else { + int z; + { z = x+1; + x = z; + } + } + return x; +} + + +int unspec () { + int c = 0; + if (c) + T[1] += f (T[1]); + else + T[2] += f (T[2]); + return T[1] + T[2]; +} + +int main (int c) { + int r = 0; + r += bts806 (); + r += unspec (); + return r; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/horwitz.c frama-c-20111001+nitrogen+dfsg/tests/slicing/horwitz.c --- frama-c-20110201+carbon+dfsg/tests/slicing/horwitz.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/horwitz.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/horwitz.opt CMD: tests/slicing/horwitz.opt - OPT: -deps -slicing-level 0 -journal-disable + OPT: -check -deps -slicing-level 0 -journal-disable / / bin/toplevel.opt -deps -val tests/slicing/horwitz.c / diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/if_many_values.c frama-c-20111001+nitrogen+dfsg/tests/slicing/if_many_values.c --- frama-c-20110201+carbon+dfsg/tests/slicing/if_many_values.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/if_many_values.c 2011-10-10 08:38:44.000000000 +0000 @@ -0,0 +1,14 @@ +/ run.config + OPT: -check -slice-value r -journal-disable -slevel 100 -then-on 'Slicing export' -print + **/ + +int r=1; + +int main() { + for (int i = -100; i < 100; i++) { + if (i != 0) + if (i) + r += 1; + } + return r; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/keep_annot.c frama-c-20111001+nitrogen+dfsg/tests/slicing/keep_annot.c --- frama-c-20110201+carbon+dfsg/tests/slicing/keep_annot.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/keep_annot.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,8 +1,8 @@ /* run.config - OPT: -context-valid-pointers -lib-entry -main f -slice-print -slice-assert f - OPT: -context-valid-pointers -lib-entry -main f -slice-print -slice-assert f -slicing-keep-annotations - OPT: -context-valid-pointers -lib-entry -main L -slice-print -slice-pragma L -slicing-keep-annotations - OPT: -context-valid-pointers -lib-entry -main L -slice-print -slice-pragma L + OPT: -check -context-valid-pointers -lib-entry -main f -slice-assert f -then-on 'Slicing export' -print + OPT: -check -context-valid-pointers -lib-entry -main f -slice-assert f -slicing-keep-annotations -then-on 'Slicing export' -print + OPT: -check -context-valid-pointers -lib-entry -main L -slice-pragma L -slicing-keep-annotations -then-on 'Slicing export' -print + OPT: -check -context-valid-pointers -lib-entry -main L -slice-pragma L -then-on 'Slicing export' -print / typedef struct { int a; double b; } las; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/libSelect.ml frama-c-20111001+nitrogen+dfsg/tests/slicing/libSelect.ml --- frama-c-20110201+carbon+dfsg/tests/slicing/libSelect.ml 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/libSelect.ml 2011-10-10 08:38:44.000000000 +0000 @@ -63,7 +63,7 @@ ( let load_source_file ?entry_point filename = Db.Files.clear (); - Db.Files.add [ Db_types.NeedCPP (filename, Db.get_preprocessor_command()) ]; + Db.Files.add [ Cil_types.NeedCPP (filename, Db.get_preprocessor_command()) ]; let entry_point, library = match entry_point with | None | Some "main" -> "main", false | Some f -> f, true @@ -83,7 +83,7 @@ let lval_term = !Db.Properties.Interp.lval kf kinst str_data in let lval = !Db.Properties.Interp.term_lval_to_lval ~result:None lval_term in let loc = !Db.Value.lval_to_loc ~with_alarms:CilE.warn_none_mode (Cil_types.Kstmt kinst) lval in - Locations.valid_enumerate_bits loc + Locations.valid_enumerate_bits ~for_writing:false loc ;; let select_data_before_stmt str_data kinst _project kf = @@ -97,7 +97,11 @@ let ki = Kernel_function.find_return kf in try let loc = Db.Value.find_return_loc kf in - let zone = Locations.valid_enumerate_bits loc in + let zone = + Locations.valid_enumerate_bits + ~for_writing:false + loc + in let mark = !S.Mark.make ~data:true ~addr:false ~ctrl:false in let before = false in !S.Select.select_stmt_zone_internal kf ki before zone mark @@ -119,12 +123,12 @@ * [numstmt]) let select_ctrl numstmt _project kf = try - let ki,_ = Kernel_function.find_from_sid numstmt in + let s = get_stmt numstmt in ( let mark = !S.Mark.make ~data:false ~addr:false ~ctrl:true in !S.Select.select_stmt_internal kf ki mark ) - !S.Select.select_stmt_ctrl_internal kf ki + !S.Select.select_stmt_ctrl_internal kf s with _ -> raise (Unknown_stmt numstmt) ;; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/loop_infinite.c frama-c-20111001+nitrogen+dfsg/tests/slicing/loop_infinite.c --- frama-c-20110201+carbon+dfsg/tests/slicing/loop_infinite.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/loop_infinite.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -deps -slice-print -slice-return main -journal-disable + OPT: -check -deps -slice-return main -journal-disable -then-on 'Slicing export' -print / int main() { volatile int a=0,b,c; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/loops.c frama-c-20111001+nitrogen+dfsg/tests/slicing/loops.c --- frama-c-20110201+carbon+dfsg/tests/slicing/loops.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/loops.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,28 +1,28 @@ / run.config - OPT: -slice-print -deps -lib-entry -main f1 -slice-pragma f1 -journal-disable - OPT: -slice-print -deps -lib-entry -main f1 -slice-assert f1 -journal-disable - OPT: -slice-print -deps -lib-entry -main f2 -slice-pragma f2 -journal-disable - OPT: -slice-print -deps -lib-entry -main f2 -slice-assert f2 -journal-disable - OPT: -slice-print -deps -main test_infinite_loop_3 -slice-value G -journal-disable - OPT: -slice-print -deps -main test_infinite_loop_4 -slice-value G -journal-disable - OPT: -slice-print -deps -main test_infinite_loop_5 -slice-value G -journal-disable - OPT: -slice-print -deps -main loop -slice-value Z -journal-disable - OPT: -slice-print -deps -slice-calls loop -journal-disable - OPT: -slice-print -deps -slice-pragma loop -journal-disable - OPT: -slice-print -deps -slice-assert loop -journal-disable - OPT: -slice-print -deps -main loop -slice-rd Y -journal-disable - OPT: -slice-print -deps -main loop -slice-rd Z -journal-disable - OPT: -slice-print -deps -main loop -slice-wr Y -journal-disable - OPT: -slice-print -deps -main loop -slice-wr Z -journal-disable - OPT: -slice-print -deps -lib-entry -main stop_f1 -slice-pragma stop_f1 -journal-disable - OPT: -slice-print -deps -lib-entry -main stop_f1 -slice-assert stop_f1 -journal-disable - OPT: -slice-print -deps -lib-entry -main stop_f2 -slice-pragma stop_f2 -journal-disable - OPT: -slice-print -deps -lib-entry -main stop_f2 -slice-assert stop_f2 -journal-disable - OPT: -slice-print -deps -slice-value Z -journal-disable - OPT: -slice-print -deps -slice-rd Y -journal-disable - OPT: -slice-print -deps -slice-rd Z -journal-disable - OPT: -slice-print -deps -slice-wr Y -journal-disable - OPT: -slice-print -deps -slice-wr Z -journal-disable + OPT: -check -deps -lib-entry -main f1 -slice-pragma f1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main f1 -slice-assert f1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main f2 -slice-pragma f2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main f2 -slice-assert f2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main test_infinite_loop_3 -slice-value G -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main test_infinite_loop_4 -slice-value G -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main test_infinite_loop_5 -slice-value G -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main loop -slice-value Z -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-calls loop -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-pragma loop -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-assert loop -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main loop -slice-rd Y -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main loop -slice-rd Z -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main loop -slice-wr Y -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -main loop -slice-wr Z -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main stop_f1 -slice-pragma stop_f1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main stop_f1 -slice-assert stop_f1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main stop_f2 -slice-pragma stop_f2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main stop_f2 -slice-assert stop_f2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-value Z -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-rd Y -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-rd Z -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-wr Y -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-wr Z -journal-disable -then-on 'Slicing export' -print diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/loop_simple.c frama-c-20111001+nitrogen+dfsg/tests/slicing/loop_simple.c --- frama-c-20110201+carbon+dfsg/tests/slicing/loop_simple.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/loop_simple.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ /* run.config - OPT: -deps -slice-print -slice-return main -journal-disable + OPT: -check -deps -slice-return main -journal-disable -then-on 'Slicing export' -print / int main() { int a,c; volatile int b = 0; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/mark_all_slices.c frama-c-20111001+nitrogen+dfsg/tests/slicing/mark_all_slices.c --- frama-c-20110201+carbon+dfsg/tests/slicing/mark_all_slices.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/mark_all_slices.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/mark_all_slices.opt CMD: tests/slicing/mark_all_slices.opt - OPT: -deps -slicing-level 3 -no-slice-callers -journal-disable + OPT: -check -deps -slicing-level 3 -no-slice-callers -journal-disable / int A, B, C, D; int A2, B2, C2, D2; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/mark_all_slices.ml frama-c-20111001+nitrogen+dfsg/tests/slicing/mark_all_slices.ml --- frama-c-20110201+carbon+dfsg/tests/slicing/mark_all_slices.ml 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/mark_all_slices.ml 2011-10-10 08:38:44.000000000 +0000 @@ -11,7 +11,7 @@ ( we are interesting in having several slices, * so use mode PreciseSlices ) - ( SlicingParameters.Mode.Calls.set 3; ) + ( SlicingKernel.Mode.Calls.set 3; ) ( Project 1 : ) diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/merge.c frama-c-20111001+nitrogen+dfsg/tests/slicing/merge.c --- frama-c-20110201+carbon+dfsg/tests/slicing/merge.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/merge.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/merge.opt CMD: tests/slicing/merge.opt - OPT: -deps -slicing-level 3 -journal-disable + OPT: -check -deps -slicing-level 3 -journal-disable / int G1, G2, G3; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/min_call.c frama-c-20111001+nitrogen+dfsg/tests/slicing/min_call.c --- frama-c-20110201+carbon+dfsg/tests/slicing/min_call.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/min_call.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/min_call.opt CMD: tests/slicing/min_call.opt - OPT: -deps -lib-entry -main g -journal-disable -slicing-level 3 + OPT: -check -deps -lib-entry -main g -journal-disable -slicing-level 3 / / dummy source file in order to test minimal calls feature diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/min_call.ml frama-c-20111001+nitrogen+dfsg/tests/slicing/min_call.ml --- frama-c-20110201+carbon+dfsg/tests/slicing/min_call.ml 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/min_call.ml 2011-10-10 08:38:44.000000000 +0000 @@ -6,7 +6,7 @@ include LibSelect;; let main _ = - (* SlicingParameters.Mode.Calls.set 3; ) + ( SlicingKernel.Mode.Calls.set 3; ) let _kf_get = Globals.Functions.find_by_name "get" in let _kf_send = Globals.Functions.find_by_name "send" in let kf_send_bis = Globals.Functions.find_by_name "send_bis" in @@ -38,11 +38,11 @@ let select = !S.Select.select_stmt_internal kf_k sb_call mark in !S.Request.add_selection_internal project select ; !S.Request.apply_all_internal project; - Log.print_on_output "@[Project1 - result1 :@\n@]"; + Log.print_on_output (fun fmt -> Format.fprintf fmt "@[Project1 - result1 :@\n@]") ; extract_and_print project; let _ff2_k = !S.Slice.create project kf_k in - Log.print_on_output "@[Project1 - result2 :@\n@]"; + Log.print_on_output (fun fmt -> Format.fprintf fmt "@[Project1 - result2 :@\n@]") ; !S.Project.pretty fmt project; extract_and_print project; @@ -60,7 +60,7 @@ !S.Request.add_selection_internal project select ; print_requests project; !S.Request.apply_all_internal project; - Log.print_on_output "@[Project3 - result :@\n@]"; + Log.print_on_output (fun fmt -> Format.fprintf fmt "@[Project3 - result :@\n@]") ; !S.Project.pretty fmt project; extract_and_print project; @@ -77,7 +77,7 @@ !S.Request.apply_next_internal project; print_requests project; !S.Request.apply_all_internal project; - Log.print_on_output "@[Project3 - result :@\n@]"; + Log.print_on_output (fun fmt -> Format.fprintf fmt "@[Project3 - result :@\n@]") ; !S.Project.pretty fmt project; extract_and_print project diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/ptr_fct.c frama-c-20111001+nitrogen+dfsg/tests/slicing/ptr_fct.c --- frama-c-20110201+carbon+dfsg/tests/slicing/ptr_fct.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/ptr_fct.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ / run.config - OPT: -main h -slice-return h -slice-print -slicing-level 1 -journal-disable + OPT: -check -main h -slice-return h -slicing-level 1 -journal-disable -then-on 'Slicing export' -print / int X ; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/select_by_annot.c frama-c-20111001+nitrogen+dfsg/tests/slicing/select_by_annot.c --- frama-c-20110201+carbon+dfsg/tests/slicing/select_by_annot.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/select_by_annot.c 2011-10-10 08:38:44.000000000 +0000 @@ -3,20 +3,20 @@ CMD: tests/slicing/select_by_annot.opt OPT: -deps -lib-entry -main main -journal-disable CMD: bin/toplevel.opt - OPT: -deps -lib-entry -main main -slice-print -slice-pragma main -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-assert main -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma modifS -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f1 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f2 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f3 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f4 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f5 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f6 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f7 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-loop-inv f8 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f8 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-assert f8 -no-slice-callers -journal-disable - OPT: -deps -lib-entry -main main -slice-print -slice-pragma f9 -no-slice-callers -journal-disable + OPT: -check -deps -lib-entry -main main -slice-pragma main -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-assert main -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma modifS -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f4 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f5 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f6 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f7 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-loop-inv f8 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f8 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-assert f8 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -lib-entry -main main -slice-pragma f9 -no-slice-callers -journal-disable -then-on 'Slicing export' -print / diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/select_calls.c frama-c-20111001+nitrogen+dfsg/tests/slicing/select_calls.c --- frama-c-20110201+carbon+dfsg/tests/slicing/select_calls.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/select_calls.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,6 @@ /* run.config - GCC: - OPT: -lib-entry -main f -slice-calls send -slice-print -journal-disable - OPT: -lib-entry -main g -slice-calls nothing -slice-print -journal-disable + OPT: -check -lib-entry -main f -slice-calls send -journal-disable -then-on 'Slicing export' -print + OPT: -check -lib-entry -main g -slice-calls nothing -journal-disable -then-on 'Slicing export' -print / void nothing (void); diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/select_return_bis.c frama-c-20111001+nitrogen+dfsg/tests/slicing/select_return_bis.c --- frama-c-20110201+carbon+dfsg/tests/slicing/select_return_bis.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/select_return_bis.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,15 +1,15 @@ / run.config - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 0 -no-slice-callers -journal-disable - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 1 -no-slice-callers -journal-disable - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 2 -no-slice-callers -journal-disable - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 3 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 0 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 1 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 2 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 3 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 1 -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 2 -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 3 -journal-disable + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 0 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 0 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 3 -journal-disable -then-on 'Slicing export' -print / int G,H,I; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/select_return.c frama-c-20111001+nitrogen+dfsg/tests/slicing/select_return.c --- frama-c-20110201+carbon+dfsg/tests/slicing/select_return.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/select_return.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,26 +1,26 @@ / run.config - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 0 -no-slice-callers -journal-disable - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 1 -no-slice-callers -journal-disable - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 2 -no-slice-callers -journal-disable - OPT: -slice-calls send -lib-entry -main g -slice-print -slicing-level 3 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 0 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 1 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 2 -no-slice-callers -journal-disable - OPT: -slice-calls send,send_bis -lib-entry -main g -slice-print -slicing-level 3 -no-slice-callers -journal-disable - OPT: -slice-calls "send , send_bis" -lib-entry -main g -slice-print -slicing-level 1 -journal-disable - OPT: -slice-calls "send, send_bis" -lib-entry -main g -slice-print -slicing-level 2 -journal-disable - OPT: -slice-calls "send ,send_bis" -lib-entry -main g -slice-print -slicing-level 3 -journal-disable - OPT: -slice-return f -lib-entry -main g -slice-print -slicing-level 0 -no-slice-callers -journal-disable - OPT: -slice-return f -lib-entry -main g -slice-print -slicing-level 1 -no-slice-callers -journal-disable - OPT: -slice-return f -lib-entry -main g -slice-print -slicing-level 2 -no-slice-callers -journal-disable - OPT: -slice-return f -lib-entry -main g -slice-print -slicing-level 3 -no-slice-callers -journal-disable - OPT: -slice-pragma f -lib-entry -main g -slice-print -slicing-level 0 -no-slice-callers -journal-disable - OPT: -slice-pragma f -lib-entry -main g -slice-print -slicing-level 1 -no-slice-callers -journal-disable - OPT: -slice-pragma f -lib-entry -main g -slice-print -slicing-level 2 -no-slice-callers -journal-disable - OPT: -slice-pragma f -lib-entry -main g -slice-print -slicing-level 3 -no-slice-callers -journal-disable - OPT: -slice-value H -lib-entry -main g -slice-print -slicing-level 1 -no-slice-callers -journal-disable - OPT: -slice-value H -lib-entry -main g -slice-print -slicing-level 2 -no-slice-callers -journal-disable - OPT: -slice-value H -lib-entry -main g -slice-print -slicing-level 3 -no-slice-callers -journal-disable + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 0 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send -lib-entry -main g -slicing-level 3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 0 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls send,send_bis -lib-entry -main g -slicing-level 3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls "send , send_bis" -lib-entry -main g -slicing-level 1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls "send, send_bis" -lib-entry -main g -slicing-level 2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-calls "send ,send_bis" -lib-entry -main g -slicing-level 3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return f -lib-entry -main g -slicing-level 0 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return f -lib-entry -main g -slicing-level 1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return f -lib-entry -main g -slicing-level 2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return f -lib-entry -main g -slicing-level 3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-pragma f -lib-entry -main g -slicing-level 0 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-pragma f -lib-entry -main g -slicing-level 1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-pragma f -lib-entry -main g -slicing-level 2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-pragma f -lib-entry -main g -slicing-level 3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-value H -lib-entry -main g -slicing-level 1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-value H -lib-entry -main g -slicing-level 2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-value H -lib-entry -main g -slicing-level 3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print / int G,H,I; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/select_simple.c frama-c-20111001+nitrogen+dfsg/tests/slicing/select_simple.c --- frama-c-20110201+carbon+dfsg/tests/slicing/select_simple.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/select_simple.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/select_simple.opt CMD: tests/slicing/select_simple.opt - OPT: -deps -journal-disable + OPT: -check -deps -journal-disable / / dummy source file in order to test select_simple.ml / diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/simple_intra_slice.c frama-c-20111001+nitrogen+dfsg/tests/slicing/simple_intra_slice.c --- frama-c-20110201+carbon+dfsg/tests/slicing/simple_intra_slice.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/simple_intra_slice.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/simple_intra_slice.opt CMD: tests/slicing/simple_intra_slice.opt - OPT: -deps -slicing-level 2 -no-slice-callers -journal-disable + OPT: -check -deps -slicing-level 2 -no-slice-callers -journal-disable / int Unknown; int G; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/simple_intra_slice.ml frama-c-20111001+nitrogen+dfsg/tests/slicing/simple_intra_slice.ml --- frama-c-20110201+carbon+dfsg/tests/slicing/simple_intra_slice.ml 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/simple_intra_slice.ml 2011-10-10 08:38:44.000000000 +0000 @@ -58,7 +58,7 @@ let kf = get_fct "f2" in Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; - select_stmt_and_print kf 8; ( c=3; ) + select_stmt_and_print kf 9; ( c=3; ) let kf = get_fct "f3" in Format.printf "@[%a@]@\n" pretty_pdg kf; @@ -69,7 +69,7 @@ Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_out0_and_print kf; - select_stmt_and_print kf 24; ( G=a; in then branch of if (c>Unknown) ) + select_stmt_and_print kf 27; ( G=a; in then branch of if (c>Unknown) ) let kf = get_fct "f5" in print_outputs "f5"; @@ -77,19 +77,20 @@ Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; select_out0_and_print kf; - select_ctrl_and_print kf 34; + select_ctrl_and_print kf 38; ( G++. VP 2008-02-04: Was ki 113, and corresponded to if(c<Unknown) { goto L2; }, not to G++ Fixed ki number to the test instead of the incrementation. As of this date, ki for G++ is 31. VP 2008-06-25 ki for G++ is 32 VP 2008-07-17 ki for G++ is 37 + BY 2011-04-14 sid for G++ is 38 ) let kf = get_fct "f6" in Format.printf "@[%a@]@\n" pretty_pdg kf; print_fct_stmts kf; - select_ctrl_and_print kf 58; + select_ctrl_and_print kf 64; ( return_label VP 2008-02-04: Was ki 135, corresponding to first stmt in the else branch of if (i) { __retres = 0; goto return_label; } @@ -98,6 +99,7 @@ As of this date, ki for return_label is 92 VP 2008-06-25: ki for return_label is 96 VP 2008-07-17: ki for return_label is 112 +BY 2011-04-14 sid for return_label is 128 ) !S.Project.pretty Format.std_formatter project diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/sizeof.c frama-c-20111001+nitrogen+dfsg/tests/slicing/sizeof.c --- frama-c-20110201+carbon+dfsg/tests/slicing/sizeof.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/sizeof.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,17 +1,17 @@ / run.config - OPT: -deps -slice-print -slice-return main -journal-disable - OPT: -deps -slice-print -slice-return SizeOf_1 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOf_2 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_pt1 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_pt2 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_pt3 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_pt_deref_1 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_tab_1 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_pt_tab_1 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_pt_tab_2 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-return SizeOfE_tab_acces_1 -no-slice-callers -journal-disable - OPT: -deps -slice-print -slice-pragma main -journal-disable - OPT: -deps -slice-print -slice-assert main -journal-disable + OPT: -check -deps -slice-return main -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOf_1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOf_2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_pt1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_pt2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_pt3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_pt_deref_1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_tab_1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_pt_tab_1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_pt_tab_2 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-return SizeOfE_tab_acces_1 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-pragma main -journal-disable -then-on 'Slicing export' -print + OPT: -check -deps -slice-assert main -journal-disable -then-on 'Slicing export' -print / struct St { int i, p, tab[5] ; } st ; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/slice_behavior.c frama-c-20111001+nitrogen+dfsg/tests/slicing/slice_behavior.c --- frama-c-20110201+carbon+dfsg/tests/slicing/slice_behavior.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/slice_behavior.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ /* run.config - OPT: -val -slice-assert f -slice-print -slicing-level 0 -journal-disable + OPT: -check -val -slice-assert f -slicing-level 0 -journal-disable -then-on 'Slicing export' -print / /@ requires a > 0; / int f(int a) { diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/slice_no_body.c frama-c-20111001+nitrogen+dfsg/tests/slicing/slice_no_body.c --- frama-c-20110201+carbon+dfsg/tests/slicing/slice_no_body.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/slice_no_body.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/slice_no_body.opt CMD: tests/slicing/slice_no_body.opt - OPT: -deps -lib-entry -main h -journal-disable + OPT: -check -deps -lib-entry -main h -journal-disable / int G; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/slice_pragma_stmt.c frama-c-20111001+nitrogen+dfsg/tests/slicing/slice_pragma_stmt.c --- frama-c-20110201+carbon+dfsg/tests/slicing/slice_pragma_stmt.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/slice_pragma_stmt.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,27 +1,27 @@ / run.config - OPT: -print -journal-disable - OPT: -main nop1 -slice-pragma nop1 -slice-print -journal-disable - OPT: -main nop2 -slice-pragma nop2 -slice-print -journal-disable - OPT: -main nop3 -slice-pragma nop3 -slice-print -journal-disable - OPT: -main nop4 -slice-pragma nop4 -slice-print -journal-disable - OPT: -main nop5 -slice-pragma nop5 -slice-print -journal-disable - OPT: -main nop6 -slice-pragma nop6 -slice-print -journal-disable - OPT: -main nop7 -slice-pragma nop7 -slice-print -journal-disable - OPT: -main nop8 -slice-pragma nop8 -slice-print -journal-disable - OPT: -main double_effect1 -slice-pragma double_effect1 -slice-print -journal-disable - OPT: -main double_effect2 -slice-pragma double_effect2 -slice-print -journal-disable - OPT: -main double_effect3 -slice-pragma double_effect3 -slice-print -journal-disable - OPT: -main double_effect4 -slice-pragma double_effect4 -slice-print -journal-disable - OPT: -main double_effect5 -slice-pragma double_effect5 -slice-print -journal-disable - OPT: -main test1 -slice-pragma test1 -slice-print -journal-disable - OPT: -main test2 -slice-pragma test2 -slice-print -journal-disable - OPT: -main test3 -slice-pragma test3 -slice-print -journal-disable - OPT: -main test4 -slice-pragma test4 -slice-print -journal-disable - OPT: -main test5 -slice-pragma test5 -slice-print -journal-disable - OPT: -main test6 -slice-pragma test6 -slice-print -journal-disable - OPT: -main test7 -slice-pragma test7 -slice-print -journal-disable - OPT: -main test8 -slice-pragma test8 -slice-print -journal-disable - OPT: -main test9 -slice-pragma test9 -slice-print -journal-disable + OPT: -check -print -journal-disable + OPT: -check -main nop1 -slice-pragma nop1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main nop2 -slice-pragma nop2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main nop3 -slice-pragma nop3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main nop4 -slice-pragma nop4 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main nop5 -slice-pragma nop5 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main nop6 -slice-pragma nop6 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main nop7 -slice-pragma nop7 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main nop8 -slice-pragma nop8 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main double_effect1 -slice-pragma double_effect1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main double_effect2 -slice-pragma double_effect2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main double_effect3 -slice-pragma double_effect3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main double_effect4 -slice-pragma double_effect4 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main double_effect5 -slice-pragma double_effect5 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test1 -slice-pragma test1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test2 -slice-pragma test2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test3 -slice-pragma test3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test4 -slice-pragma test4 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test5 -slice-pragma test5 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test6 -slice-pragma test6 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test7 -slice-pragma test7 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test8 -slice-pragma test8 -journal-disable -then-on 'Slicing export' -print + OPT: -check -main test9 -slice-pragma test9 -journal-disable -then-on 'Slicing export' -print / typedef int stmt, expr, slice; int x, y ; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/switch.c frama-c-20111001+nitrogen+dfsg/tests/slicing/switch.c --- frama-c-20110201+carbon+dfsg/tests/slicing/switch.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/switch.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing/switch.opt CMD: tests/slicing/switch.opt - OPT: -deps -journal-disable + OPT: -check -deps -journal-disable / int main (char choix) { int x = 0, y = 0, z = 0; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/top2.c frama-c-20111001+nitrogen+dfsg/tests/slicing/top2.c --- frama-c-20110201+carbon+dfsg/tests/slicing/top2.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/top2.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,6 +1,6 @@ / run.config -* OPT: -slicing-level 2 -slice-pragma main -slice-print -journal-disable -* OPT: -slicing-level 2 -slice-return main -slice-print -journal-disable +* OPT: -check -slicing-level 2 -slice-pragma main -journal-disable -then-on 'Slicing export' -print +* OPT: -check -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print / diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/top.c frama-c-20111001+nitrogen+dfsg/tests/slicing/top.c --- frama-c-20110201+carbon+dfsg/tests/slicing/top.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/top.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,7 +1,7 @@ / run.config -* OPT: -slicing-level 0 -slice-return uncalled -slice-print -no-slice-callers -journal-disable -* OPT: -slicing-level 2 -slice-return main -slice-print -journal-disable -* OPT: -slicing-level 2 -slice-return strlen -slice-print -journal-disable +* OPT: -check -slicing-level 0 -slice-return uncalled -no-slice-callers -journal-disable -then-on 'Slicing export' -print +* OPT: -check -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print +* OPT: -check -slicing-level 2 -slice-return strlen -journal-disable -then-on 'Slicing export' -print * * * diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/undef-fun.c frama-c-20111001+nitrogen+dfsg/tests/slicing/undef-fun.c --- frama-c-20110201+carbon+dfsg/tests/slicing/undef-fun.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/undef-fun.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,5 +1,5 @@ /* run.config - OPT: -slice-print -slice-undef-functions -slice-return f -journal-disable + OPT: -check -slice-undef-functions -slice-return f -journal-disable -then-on 'Slicing export' -print diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/unitialized.c frama-c-20111001+nitrogen+dfsg/tests/slicing/unitialized.c --- frama-c-20110201+carbon+dfsg/tests/slicing/unitialized.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/unitialized.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,8 +1,8 @@ /* run.config - OPT: -slice-print -slice-pragma g -journal-disable - OPT: -slice-print -slice-assert g -journal-disable - OPT: -slice-print -slice-assert main -journal-disable - OPT: -slice-print -slice-return g -journal-disable + OPT: -check -slice-pragma g -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-assert g -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-assert main -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return g -journal-disable -then-on 'Slicing export' -print / int X1, X2 ; diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/unravel-flavors.c frama-c-20111001+nitrogen+dfsg/tests/slicing/unravel-flavors.c --- frama-c-20110201+carbon+dfsg/tests/slicing/unravel-flavors.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/unravel-flavors.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,9 +1,8 @@ / run.config - GCC: - OPT: -slice-print -slice-undef-functions -slice-return send1 -journal-disable - OPT: -slice-print -slice-undef-functions -slice-return send2 -journal-disable - OPT: -slice-print -slice-undef-functions -slice-return send3 -journal-disable - OPT: -slice-print -slice-undef-functions -slice-return send4 -journal-disable + OPT: -check -slice-undef-functions -slice-return send1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-undef-functions -slice-return send2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-undef-functions -slice-return send3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-undef-functions -slice-return send4 -journal-disable -then-on 'Slicing export' -print / / Small example derived from examples given for UNRAVEL tool : / diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/unravel-point.c frama-c-20111001+nitrogen+dfsg/tests/slicing/unravel-point.c --- frama-c-20110201+carbon+dfsg/tests/slicing/unravel-point.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/unravel-point.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,10 +1,9 @@ / run.config - GCC: - OPT: -slice-print -calldeps -slice-return send1 -journal-disable - OPT: -slice-print -calldeps -slice-return send2 -journal-disable - OPT: -slice-print -calldeps -slice-return send3 -journal-disable - OPT: -slice-print -calldeps -slice-return send4 -journal-disable - + OPT: -check -calldeps -slice-return send1 -journal-disable -then-on 'Slicing export' -print + OPT: -check -calldeps -slice-return send2 -journal-disable -then-on 'Slicing export' -print + OPT: -check -calldeps -slice-return send3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -calldeps -slice-return send4 -journal-disable -then-on 'Slicing export' -print + OPT: -check -calldeps -slice-return send1 -slice-return send4 -journal-disable -then-on 'Slicing export' -check -calldeps -slice-return send1_slice_1 -print -then-on 'Slicing export 2' -print diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/unravel-variance.c frama-c-20111001+nitrogen+dfsg/tests/slicing/unravel-variance.c --- frama-c-20110201+carbon+dfsg/tests/slicing/unravel-variance.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/unravel-variance.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,10 +1,9 @@ /* run.config - GCC: - OPT: -slice-print -slice-calls printf1 -journal-disable -float-normal - OPT: -slice-print -slice-calls printf2 -journal-disable -float-normal - OPT: -slice-print -slice-calls printf3 -journal-disable -float-normal - OPT: -slice-print -slice-calls printf4 -journal-disable -float-normal - OPT: -slice-print -slice-calls printf5 -journal-disable -float-normal + OPT: -check -slice-calls printf1 -journal-disable -float-normal -then-on 'Slicing export' -print + OPT: -check -slice-calls printf2 -journal-disable -float-normal -then-on 'Slicing export' -print + OPT: -check -slice-calls printf3 -journal-disable -float-normal -then-on 'Slicing export' -print + OPT: -check -slice-calls printf4 -journal-disable -float-normal -then-on 'Slicing export' -print + OPT: -check -slice-calls printf5 -journal-disable -float-normal -then-on 'Slicing export' -print / / Small example devired from examples given for UNRAVEL tool : / diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing/variadic.c frama-c-20111001+nitrogen+dfsg/tests/slicing/variadic.c --- frama-c-20110201+carbon+dfsg/tests/slicing/variadic.c 2011-02-07 13:41:41.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing/variadic.c 2011-10-10 08:38:44.000000000 +0000 @@ -1,9 +1,8 @@ / run.config -* GCC: -* OPT: -slice-return f3 -slice-print -no-slice-callers -journal-disable -* OPT: -slice-return f3 -slice-print -journal-disable -* OPT: -slice-return main -slice-print -journal-disable -* OPT: -slice-return main -slice-print -slicing-level 3 -journal-disable + OPT: -check -slice-return f3 -no-slice-callers -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return f3 -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return main -journal-disable -then-on 'Slicing export' -print + OPT: -check -slice-return main -slicing-level 3 -journal-disable -then-on 'Slicing export' -print / #include "../pdg/variadic.c" diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing2/adpcm.c frama-c-20111001+nitrogen+dfsg/tests/slicing2/adpcm.c --- frama-c-20110201+carbon+dfsg/tests/slicing2/adpcm.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing2/adpcm.c 2011-10-10 08:39:10.000000000 +0000 @@ -1,7 +1,7 @@ / run.config EXECNOW: make -s tests/slicing2/adpcm.opt CMD: tests/slicing2/adpcm.opt - OPT: -no-annot -deps -slicing-level 2 -journal-disable + OPT: -check -no-annot -deps -slicing-level 2 -journal-disable / #include "tests/test/adpcm.c" diff -Nru frama-c-20110201+carbon+dfsg/tests/slicing2/adpcm.ml frama-c-20111001+nitrogen+dfsg/tests/slicing2/adpcm.ml --- frama-c-20110201+carbon+dfsg/tests/slicing2/adpcm.ml 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/slicing2/adpcm.ml 2011-10-10 08:39:10.000000000 +0000 @@ -5,7 +5,7 @@ include LibSelect;; -( Parameters.slicing_level := 2;; = MinimizeNbCalls ) +( Kernel.slicing_level := 2;; = MinimizeNbCalls ) ( let resname = "tests/slicing2/adpcm.sliced" in diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/bts334.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/bts334.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/bts334.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/bts334.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,7 +1,7 @@ /run.config OPT: -main main_init -sparecode-analysis -sparecode-no-annot -journal-disable - OPT: -main main_init -slice-print -slice-pragma loop_body -journal-disable - OPT: -main main_init -slice-print -slice-pragma loop_body -calldeps -journal-disable + OPT: -main main_init -slice-pragma loop_body -journal-disable -then-on 'Slicing export' -print + OPT: -main main_init -slice-pragma loop_body -calldeps -journal-disable -then-on 'Slicing export' -print / int kf ; int k[2] ; diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/bts927.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/bts927.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/bts927.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/bts927.c 2011-10-10 08:39:09.000000000 +0000 @@ -0,0 +1,25 @@ +/* run.config + OPT: -journal-disable -sparecode + OPT: -journal-disable -val-signed-overflow-alarms -sparecode +/ + +/ The purpose of these tests is to check if the conditions are removed + * when the branch is statically known. / + +int f (int a) { + int c = a+1; + return (c > 0) ? 1 : 0; +} + +int main (int x) { + //@ assert x>5; + if (x > 5) { + int y = f(x); + if (y < 2) // always true + return f(x); + else return -1; + } else { + return 4; + } +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/calls.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/calls.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/calls.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/calls.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable - OPT: -slicing-level 2 -slice-return main -slice-print -journal-disable + OPT: -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print / int G; diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/dead_code.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/dead_code.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/dead_code.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/dead_code.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config - OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable - OPT: -slicing-level 2 -slice-return main -slice-print -journal-disable + OPT: -sparecode-debug 1 -sparecode -journal-disable + OPT: -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print / int main (void) { diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/glob_decls.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/glob_decls.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/glob_decls.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/glob_decls.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ / run.config OPT: -lib-entry -journal-disable -sparecode-debug 1 -sparecode-analysis - OPT: -lib-entry -slice-pragma main -slice-return main -slice-print -journal-disable + OPT: -lib-entry -slice-pragma main -slice-return main -journal-disable -then-on 'Slicing export' -print OPT: -journal-disable -sparecode-debug 1 -rm-unused-globals / @@ -36,11 +36,17 @@ Tx X = sizeof (Size); int Y; +int use_in_PX_init; +int PX; + /@ requires S2.a > S2.b ; / int main (int x, Ts s) { //@ slice pragma expr S2 ; int y = 3; y += Y; + y += PX; //@ assert X > 0; return X + x; } + +int PX = &use_in_PX_init; diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/intra.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/intra.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/intra.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/intra.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,9 +1,9 @@ /* run.config OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable - OPT: -slicing-level 2 -slice-return main -slice-print -journal-disable + OPT: -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print OPT: -main main2 -sparecode-analysis -journal-disable - OPT: -main main2 -slice-return main2 -slice-print -journal-disable - OPT: -main main2 -slice-return main2 -slice-assert f10 -slice-print -journal-disable + OPT: -main main2 -slice-return main2 -journal-disable -then-on 'Slicing export' -print + OPT: -main main2 -slice-return main2 -slice-assert f10 -journal-disable -then-on 'Slicing export' -print / / Waiting for results such as: diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/params.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/params.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/params.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/params.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,6 +1,6 @@ /* run.config OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable - OPT: -slicing-level 2 -slice-return main -slice-print -journal-disable + OPT: -slicing-level 2 -slice-return main -journal-disable -then-on 'Slicing export' -print / / This is an example from #529. 'y' in [main1] should be visible to get a diff -Nru frama-c-20110201+carbon+dfsg/tests/sparecode/top.c frama-c-20111001+nitrogen+dfsg/tests/sparecode/top.c --- frama-c-20110201+carbon+dfsg/tests/sparecode/top.c 2011-02-07 13:41:51.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/sparecode/top.c 2011-10-10 08:39:09.000000000 +0000 @@ -1,9 +1,17 @@ /* run.config - DONTRUN: don't run a test which raises an exception (PdgTypes.Pdg.Top) OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable -main main_top OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable -main main_call_top + OPT: -sparecode-debug 1 -sparecode-analysis -journal-disable -main main_top_not_used / +void print (int x); + +int not_used_in_main_top (int x) { + print (x); + return x+2; +} + + int f (int a) { return a+1; } @@ -16,5 +24,14 @@ int main_call_top (void) { int x = main_top (2, 0, 1); + x = not_used_in_main_top (x); return x; } + +int main_top_not_used (void) { + int a = main_top (2, 0, 1); + int x = f (2); + return x; +} + + diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/abrupt.i frama-c-20111001+nitrogen+dfsg/tests/spec/abrupt.i --- frama-c-20110201+carbon+dfsg/tests/spec/abrupt.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/abrupt.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,37 @@ +/ run.config + STDOPT: +"-simplify-cfg" +/ + +int f (int c) { + int x = 0; + switch (c) { + /@ breaks x == 1; / + { + case 0: x = 1; break; + case 1: x = 3; + case 2: x++; + default: x++; + }} + while (1) { + /@ breaks x == \old(x); + continues x == \old(x) + 1; + / + { + if (x < c) { x++; continue; } + break; + } + } + return x; +} + +/@ ensures x==1 ==> \result==1; / +int f5 (int x){ + int y = 0; + + switch (x) { + case 1 : + while (x>0) /@ breaks x > 0; / break ; + y = 1; + } + return y; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/all.c frama-c-20111001+nitrogen+dfsg/tests/spec/all.c --- frama-c-20110201+carbon+dfsg/tests/spec/all.c 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/all.c 2011-10-10 08:38:50.000000000 +0000 @@ -1,9 +1,10 @@ / Terms / -/@ lemma a: \forall int x ; x --> x == -1 ; / // KO -/@ lemma b: \forall int x ; x <--> x == -1 ; / // KO -/@ lemma c: (\let x = 0 ; x+1) == 1 ; / // OK -/@ lemma d: (name:77) == 76+1 ; / // OK +/@ lemma e: \forall int x ; (x & x) == x ; / // KO pretty printing priority +/@ lemma a: \forall int x ; (x --> x) == -1 ; / // KO pretty printing priority +/@ lemma b: \forall int x ; (x <--> x) == -1 ; / // KO pretty printing priority +/@ lemma c: (\let x = 0 ; x+1) == 1 ; / // OK +/@ lemma d: (name:77) == 76+1 ; / // OK / Predicates / /@ diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/array_conversion.c frama-c-20111001+nitrogen+dfsg/tests/spec/array_conversion.c --- frama-c-20110201+carbon+dfsg/tests/spec/array_conversion.c 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/array_conversion.c 2011-10-10 08:38:50.000000000 +0000 @@ -24,3 +24,15 @@ int f1(foo x) { return x[3]; } int g1() { return f1(X); } + +//@ axiomatic ax { logic boolean p{L}(int b); } + +int a[10]; + +void ftest(void) { + //@ assert p(&a[0]); + //@ assert p( a ); +} + + +//@ lemma array_not_null: a != \null; diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/assigns_result.i frama-c-20111001+nitrogen+dfsg/tests/spec/assigns_result.i --- frama-c-20110201+carbon+dfsg/tests/spec/assigns_result.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/assigns_result.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,16 @@ +/ run.config + STDOPT: +"-deps" +/ +int X,Y; + +/@ assigns \result; + assigns \exit_status; +/ +int f(void); + +/@ assigns \result \from X; + assigns \exit_status \from Y; +/ +int g(void); + +void main(void) { f(); g(); } diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/behavior_assert.c frama-c-20111001+nitrogen+dfsg/tests/spec/behavior_assert.c --- frama-c-20110201+carbon+dfsg/tests/spec/behavior_assert.c 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/behavior_assert.c 2011-10-10 08:38:50.000000000 +0000 @@ -32,7 +32,50 @@ G = i; } + +int abs(short x) { + if (x <= 0) + return -x; + else return x; +} + +/@ + behavior not_null: + assumes a != 0; + ensures \result > 0; + behavior null: + assumes a == 0; + ensures \result == 0; + complete behaviors not_null, null; +/ +int h1(short a) { + int r = abs((a-a)+a); + int r2 = r; + /@ for not_null: + assert r != 0; / + return r; +} + +extern int c; + +void h2 () { + int a, b; + if (c) + if (c+1) + if (c+2) + a = -2; + else + a = 3; + else + a = -4; + else + a = -1; + b = h1 (a); + //@ assert b > 0; +} + void main(void) { f(); g(); + h2(); } diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0440.i frama-c-20111001+nitrogen+dfsg/tests/spec/bts0440.i --- frama-c-20110201+carbon+dfsg/tests/spec/bts0440.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0440.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,10 @@ +int fact(int n) { + int r = 1 ; + while ( n > 0 ) { + //@ ensures n >= 0 ; + before: + r = n-- ; + //@ assert r == \at(rn,before) ; + } + return r ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0549.i frama-c-20111001+nitrogen+dfsg/tests/spec/bts0549.i --- frama-c-20110201+carbon+dfsg/tests/spec/bts0549.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0549.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,29 @@ +int t1[10], t2[10] ; + +//@ logic int a1 = t1 + 0; +//@ logic int * a2 = &t1[0]; +//@ logic int * a3 = &t1 ; +//@ logic int a4 = t1 ; // should not be accepted +//@ logic int * a5 = (int )t1; +//@ logic int b1 = \let x = t1 + 0; x ; +//@ logic int * b2 = \let x = &t1[0]; x ; +//@ logic int * b3 = \let x = &t1 ; x ; +//@ logic int b4 = \let x = t1 ; x ; // should not be accepted + +int main () { + int i ; + for (i=0 ; i < 10 ; i++) { + t1[i] = 0 ; + t2[i] = 0 ; + } + if (t1 == t2) { + /* C tests the address of the first elements, + * so the then-branch is dead. / + //@ assert \false; + } + else { + / ACSL tests the contents of the arrays, + * here they are the same. / + //@ assert (t1==t2) ; // even with the previous C + } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0570.i frama-c-20111001+nitrogen+dfsg/tests/spec/bts0570.i --- frama-c-20110201+carbon+dfsg/tests/spec/bts0570.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0570.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,5 @@ +int main(char data ) +{ + //@ assert \pointer_comparable(data, (void )0); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0578.i frama-c-20111001+nitrogen+dfsg/tests/spec/bts0578.i --- frama-c-20110201+carbon+dfsg/tests/spec/bts0578.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0578.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,12 @@ +/ run.config + OPT: -print -load-script ./tests/spec/bts0578.ml +/ + +/@ behavior foo: ensures \true; / +void main(void) { + int i, t[10]; + /@ loop assigns t[0..i]; + for foo: loop assigns t[0..i]; + / + for (i = 0; i < 10; i++) { t[i] = 0; } +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0578.ml frama-c-20111001+nitrogen+dfsg/tests/spec/bts0578.ml --- frama-c-20110201+carbon+dfsg/tests/spec/bts0578.ml 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0578.ml 2011-10-10 08:38:50.000000000 +0000 @@ -1,10 +1,9 @@ open Cil_types -open Db_types open Logic_const let main () = - let s, _ = Kernel_function.find_from_sid 2 in - let add a = Annotations.add s [] (Before (User (new_code_annotation a))) in + let s, kf = Kernel_function.find_from_sid 2 in + let add a = Annotations.add kf s [] (User (new_code_annotation a)) in add (AInvariant(["foo"], true, ptrue)); add (AVariant(tinteger 0, None)); add (AInvariant([], true, ptrue)); diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0589.i frama-c-20111001+nitrogen+dfsg/tests/spec/bts0589.i --- frama-c-20110201+carbon+dfsg/tests/spec/bts0589.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0589.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,9 @@ +int x; + +int g(void) +{ int a; + //@ assigns a,x ; + a = x++ ; + return a; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0655.i frama-c-20111001+nitrogen+dfsg/tests/spec/bts0655.i --- frama-c-20110201+carbon+dfsg/tests/spec/bts0655.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0655.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,17 @@ +/ run.config + DONTRUN: bug fix in progress + OPT: -load-script tests/spec/bts0655.ml +/ +/@ + @ ensures \result == \max( a, b ); + @ ensures \result != \min( a, b ); + @ ensures \max(a,b) != \min(a+1,b); + @ ensures a == \abs( a ); + @/ +unsigned int +max( unsigned int a, unsigned int b ) +{ + int i = a > b ? a : b; + //@ assert i == \max( \at(a,Pre), \at(b,Pre) ); + return i; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0655.ml frama-c-20111001+nitrogen+dfsg/tests/spec/bts0655.ml --- frama-c-20110201+carbon+dfsg/tests/spec/bts0655.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0655.ml 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,25 @@ +include + Plugin.Register( + struct + let name = "bts0655" + let shortname = "bts0655" + let help = "inspects relevant AST parts of bts0655.i" + end) + + +class check_float = +object +inherit Visitor.frama_c_inplace + method vterm t = + result "term %a has type %a" + !Ast_printer.d_term t !Ast_printer.d_logic_type t.Cil_types.term_type; + Cil.DoChildren +end + +let run () = + let f = Ast.get () in + Visitor.visitFramacFileSameGlobals (new check_float) f +;; + +Db.Main.extend run +;; diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0698.i frama-c-20111001+nitrogen+dfsg/tests/spec/bts0698.i --- frama-c-20110201+carbon+dfsg/tests/spec/bts0698.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0698.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,31 @@ +/ -------------------------------------------------------------------------- / +/ --- Testing logic casts on array types --- / +/ -------------------------------------------------------------------------- / + +//@ predicate P(int x[2]) = x[0] < x[1] ; + +//@ predicate Q{L}(int x) = x[0] < x[1] ; + +//@ predicate Correct{L}(int x) = P((int[2]) x) ; + +//@ predicate Incorrect{L}(int x[2]) = Q{L}((int ) x) ; + +int t[2] ; +int * a ; + +void f(void) +{ + t[0] = 10 ; + t[1] = 20 ; + //@ assert P(t) ; + //@ assert Q((int )t) ; +} + +//@ requires \valid(a+(0..1)) ; +void g(void) +{ + a[0] = 10 ; + a[1] = 20 ; + //@ assert P((int[2])a) ; + //@ assert Q(a) ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/bts0812.c frama-c-20111001+nitrogen+dfsg/tests/spec/bts0812.c --- frama-c-20110201+carbon+dfsg/tests/spec/bts0812.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/bts0812.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,8 @@ +/@ lemma fib_3: \true; // proved automatically / +/@ lemma fib_46: \true; / + +/@ assigns \nothing; +// Bla / +void main() { +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/char_cst.c frama-c-20111001+nitrogen+dfsg/tests/spec/char_cst.c --- frama-c-20110201+carbon+dfsg/tests/spec/char_cst.c 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/char_cst.c 2011-10-10 08:38:50.000000000 +0000 @@ -1,7 +1,10 @@ -/ see bug #137 / /@ requires c != '0'; - behavior default: assumes c!='\''; - behavior hexa: assumes c != '\xAB'; - behavior oct: assumes c!= '\123'; + behavior quote: assumes c=='\'' ; + behavior default: assumes c!='\'' && c!='a'; + behavior slash: assumes c=='\\' ; + behavior other: assumes c!='\\' && c!='a'; + behavior hexa: assumes c!='\xAB'; + behavior oct: assumes c!='\123'; + behavior string: assumes ""!="\"" && ""=="" ; / void f(char c) { } diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/comparison.i frama-c-20111001+nitrogen+dfsg/tests/spec/comparison.i --- frama-c-20110201+carbon+dfsg/tests/spec/comparison.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/comparison.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,15 @@ +/ run.config + OPT: -load-script tests/spec/comparison.ml +/ + +/@ predicate foo(boolean a, boolean b) = a == b; / + +void main(void) { + int x = 0, y = 0; + long z = 0L; + /@ assert x == y; / + /@ assert x == z; / + /@ assert (long)x == z; / + /@ assert foo(x==y,x==z); / + /@ assert foo(z==(long)y, y == x); / +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/comparison.ml frama-c-20111001+nitrogen+dfsg/tests/spec/comparison.ml --- frama-c-20110201+carbon+dfsg/tests/spec/comparison.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/comparison.ml 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,31 @@ +open Cil_types +open Cil + +let run () = + let vis = + object + inherit Visitor.frama_c_inplace + method vterm t = + match t.term_node with + | TBinOp ((Lt | Gt | Le | Ge | Eq | Ne), t1, t2) -> + Kernel.result + "Term comparison between %a of type %a and %a of type %a" + !Ast_printer.d_term t1 !Ast_printer.d_logic_type t1.term_type + !Ast_printer.d_term t2 !Ast_printer.d_logic_type t2.term_type; + DoChildren + | _ -> DoChildren + method vpredicate p = + match p with + | Prel ((Rlt | Rgt | Rle | Rge | Req | Rneq), t1, t2) -> + Kernel.result + "Predicate comparison between %a of type %a and %a of type %a" + !Ast_printer.d_term t1 !Ast_printer.d_logic_type t1.term_type + !Ast_printer.d_term t2 !Ast_printer.d_logic_type t2.term_type; + DoChildren + | _ -> DoChildren + end + in + Visitor.visitFramacFileSameGlobals vis (Ast.get()) +;; + +let () = Db.Main.extend run diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/constant_predicate.i frama-c-20111001+nitrogen+dfsg/tests/spec/constant_predicate.i --- frama-c-20110201+carbon+dfsg/tests/spec/constant_predicate.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/constant_predicate.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,15 @@ +int x; + +/@ predicate P{A} = x == 42; / + +/@ logic integer f{B} = x + 42; / + +/@ lemma foo{C}: P ==> f == 84; / + +/@ ensures f == 84; / +void g () { + + x = 42; + /@ assert P; / + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/dec.h frama-c-20111001+nitrogen+dfsg/tests/spec/dec.h --- frama-c-20110201+carbon+dfsg/tests/spec/dec.h 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/dec.h 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,8 @@ +#ifndef DEC +#define DEC + +/@ axiomatic S { logic integer F(integer x) ; } / + +//@ logic integer X = 42; + +#endif diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/default_assigns_bts0966.i frama-c-20111001+nitrogen+dfsg/tests/spec/default_assigns_bts0966.i --- frama-c-20110201+carbon+dfsg/tests/spec/default_assigns_bts0966.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/default_assigns_bts0966.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,35 @@ +/ run.config + OPT: -val -print + / + +int auto_states[4] ; // = { 1 , 0 , 0, 0 }; + +enum states { + Init = 0, + Copy = 1, + Set=2, + Final = 3 +}; + +// contract with missing "complete behaviors" +/@ + ensures \true; + behavior from_init: + assumes auto_states[Init] == 1; + ensures (auto_states[Copy] == 1) && (auto_states[Init] == 0); + assigns auto_states[Init], auto_states[Copy]; + + behavior from_other: + assumes (auto_states[Init] == 0); + assigns \nothing; + +/ +void copy(int x); + +int main() { + auto_states[Init] = 1; + auto_states[Copy] = 0; + auto_states[Set] = 0; + auto_states[Final] = 0; + copy(0); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/exit_clause.c frama-c-20111001+nitrogen+dfsg/tests/spec/exit_clause.c --- frama-c-20110201+carbon+dfsg/tests/spec/exit_clause.c 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/exit_clause.c 2011-10-10 08:38:50.000000000 +0000 @@ -17,3 +17,14 @@ exits \exit_status==x; / int may_exit(int x) { if (x) exit(0); return 0; } + +// Following spec must be rejected + +//@ exits \result == 0; +int f () { return 0; } + +//@ requires \exit_status == 0; ensures \exit_status == 0; +void g () { + //@ assert \exit_status == 0; + exit(0); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/first.c frama-c-20111001+nitrogen+dfsg/tests/spec/first.c --- frama-c-20110201+carbon+dfsg/tests/spec/first.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/first.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,11 @@ +/* run.config + OPT: -print tests/spec/third.c tests/spec/second.c -journal-disable +/ +/@ behavior b: + requires \valid(first); + ensures \result == 0;/ +int bar(int first); + +void main (int * c) { + bar(c); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/local.c frama-c-20111001+nitrogen+dfsg/tests/spec/local.c --- frama-c-20110201+carbon+dfsg/tests/spec/local.c 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/local.c 2011-10-10 08:38:50.000000000 +0000 @@ -14,3 +14,7 @@ P(f(x,y),\result); / int g(int x, int y) { return (x+y+1); } + +//@ axiomatic a { predicate P(integer v); } +//@ lemma l1: \let p=\lambda integer x; P(x); p(1); +//@ lemma l2: \let p=P(1); p ; diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/merge_1.i frama-c-20111001+nitrogen+dfsg/tests/spec/merge_1.i --- frama-c-20110201+carbon+dfsg/tests/spec/merge_1.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/merge_1.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,11 @@ +/ run.config + STDOPT: +"tests/spec/merge_2.i" + / +/@ requires \valid(s); + @ assigns \nothing; + @ ensures \result == 0 && \valid(s); + @/ +extern int slen(const char s); + +/@ requires x>=0; / +extern int f(int x); diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/merge_2.i frama-c-20111001+nitrogen+dfsg/tests/spec/merge_2.i --- frama-c-20110201+carbon+dfsg/tests/spec/merge_2.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/merge_2.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,23 @@ +/* run.config + * DONTRUN: part of merge_1.i + / +/@ requires \valid(str2); + @ assigns \nothing; + @ + @/ +int slen(const char str2); + +/@ + @ assigns \nothing; + @ ensures \result == 0 && \valid(str); + @/ +int slen(const char* str) { + const char s; + for (s = str; s; ++s); + return(s - str); +} + +//@ requires y>=0; +int f(int y); + +int f(int z) { return z-1; } diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/merge_bts938_1.c frama-c-20111001+nitrogen+dfsg/tests/spec/merge_bts938_1.c --- frama-c-20110201+carbon+dfsg/tests/spec/merge_bts938_1.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/merge_bts938_1.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,5 @@ +/* run.config + DONTRUN: main test is merge_bts938.c +/ + +#include "tests/spec/merge_bts938.h" diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/merge_bts938.c frama-c-20111001+nitrogen+dfsg/tests/spec/merge_bts938.c --- frama-c-20110201+carbon+dfsg/tests/spec/merge_bts938.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/merge_bts938.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,5 @@ +/ run.config + STDOPT: +"tests/spec/merge_bts938_1.c" +/ + +#include "tests/spec/merge_bts938.h" diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/merge_bts938.h frama-c-20111001+nitrogen+dfsg/tests/spec/merge_bts938.h --- frama-c-20110201+carbon+dfsg/tests/spec/merge_bts938.h 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/merge_bts938.h 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,3 @@ +extern int tab[10]; +//@ ensures tab == {tab \with [0]= (int)0} ; +int main(void) ; diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/multi_labels.i frama-c-20111001+nitrogen+dfsg/tests/spec/multi_labels.i --- frama-c-20110201+carbon+dfsg/tests/spec/multi_labels.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/multi_labels.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,6 @@ +int labels (void) { + int x = 0 ; + L1: L2: + //@ assert \at(x,L1) == \at(x,L2) ; + return x ; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/old_prm.i frama-c-20111001+nitrogen+dfsg/tests/spec/old_prm.i --- frama-c-20110201+carbon+dfsg/tests/spec/old_prm.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/old_prm.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,7 @@ +struct st { int t[10]; } S; +int i,j ; + +//@ ensures S.t[i] == s.t[j] + y[x]; +void main (struct st s, int x, int y) { + S.t[i] = s.t[j] + y[x]; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/pragma.i frama-c-20111001+nitrogen+dfsg/tests/spec/pragma.i --- frama-c-20110201+carbon+dfsg/tests/spec/pragma.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/pragma.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,20 @@ +#typedef int B +#pragma +#pragma A +#pragma A() +#pragma A("A" "A", A, B, 2:4) +#pragma B +#pragma B() +#pragma B("A" "A", A, B, 2:4) + +#pragma 1:3 +#pragma default:1 +#pragma (1 ? A : B) + +#pragma "A" +#pragma 1 +#pragma A 0 +#pragma A B "C" +#pragma B A "C" 4 "E" +#pragma 0 A B "C" D 5 + diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/precedence.i frama-c-20111001+nitrogen+dfsg/tests/spec/precedence.i --- frama-c-20110201+carbon+dfsg/tests/spec/precedence.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/precedence.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,5 @@ +int x[10] ; +//@lemma prio_unary_plus: 3 - +2 +2 == 3; +//@lemma prio_unary_minus: 3 - -2 -2 == 3; +//@lemma prio_unary_amp: (&x[1] - &x[0] & &x[2] - &x[2]) == 0; +//@lemma prio_unary_star: 0 * &x[2] &x[2] == 0; diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/pred_def.i frama-c-20111001+nitrogen+dfsg/tests/spec/pred_def.i --- frama-c-20110201+carbon+dfsg/tests/spec/pred_def.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/pred_def.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1 @@ +//@ predicate f(integer x) = x+1; diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/predicates.c frama-c-20111001+nitrogen+dfsg/tests/spec/predicates.c --- frama-c-20110201+carbon+dfsg/tests/spec/predicates.c 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/predicates.c 2011-10-10 08:38:50.000000000 +0000 @@ -12,3 +12,5 @@ /@ predicate S(int p) = \let z = 0 ; p == \let x = 0 ; ((\let y = z ; x < y) ? 1 + 2 : (\let y = x ; y)) + 2 ; / +//@ axiomatic a { predicate P(integer v); } +//@ lemma l: P(1)?P(2):P(3) ; diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/property_test.i frama-c-20111001+nitrogen+dfsg/tests/spec/property_test.i --- frama-c-20110201+carbon+dfsg/tests/spec/property_test.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/property_test.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,14 @@ +/ run.config + OPT: -load-script tests/spec/property_test.ml +/ + +int X; + +/@ requires X >= 0; + ensures X >= 0; +/ +int main (int c) { + if (c) X++; + /@ assert X >= \at(X,Pre); / + return X; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/property_test.ml frama-c-20111001+nitrogen+dfsg/tests/spec/property_test.ml --- frama-c-20110201+carbon+dfsg/tests/spec/property_test.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/property_test.ml 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,37 @@ +open Cil +open Cil_types + +class visit prj = + object(self) + inherit Visitor.frama_c_copy prj + method vbehavior b = + let x = Globals.Vars.find_from_astinfo "X" VGlobal in + let x = Cil.cvar_to_lvar x in + let c = + Globals.Vars.find_from_astinfo + "c" (VFormal (Extlib.the self#current_kf)) + in + let c = Cil.cvar_to_lvar c in + b.b_assigns <- + Writes + [ Logic_const.new_identified_term (Logic_const.tvar x), + From [ Logic_const.new_identified_term (Logic_const.tvar x); + Logic_const.new_identified_term (Logic_const.tvar c)] + ]; + DoChildren + end + +let show_properties () = + Format.printf "In project %a:@." Project.pretty (Project.current()); + Property_status.iter + (fun p -> Format.printf "Status of %a: %a@." + Property.pretty p Property_status.pretty (Property_status.get p)) + +let run () = + let prj = + File.create_project_from_visitor "property_test" (fun p -> new visit p) + in + show_properties (); + Project.on prj show_properties () + +let () = Db.Main.extend run diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/returns.i frama-c-20111001+nitrogen+dfsg/tests/spec/returns.i --- frama-c-20110201+carbon+dfsg/tests/spec/returns.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/returns.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,23 @@ +/@ ensures \result != c; / +int f (int c) { + + /@ returns \result == 0; / + if (c) return 0; + return 42; + +} + +/@ requires \valid(a); + ensures a > 0; +/ +int g(int a) { + a++; + /@ + behavior neg: + assumes a < 0; + returns \old(a) == -a; + / + if (a < 0) { a = -a; return -1; } + if (a != 0) { a++; return 0; } + return 1; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/rewrite_ensures.ml frama-c-20111001+nitrogen+dfsg/tests/spec/rewrite_ensures.ml --- frama-c-20110201+carbon+dfsg/tests/spec/rewrite_ensures.ml 2011-02-07 13:41:42.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/rewrite_ensures.ml 2011-10-10 08:38:50.000000000 +0000 @@ -1,9 +1,10 @@ (* dynamic plug-in to test rewriting of formals in ensures clauses ) -let rewrite _ = +let rewrite () = Ast.compute (); Globals.Functions.iter - (fun kf -> kf.Db_types.spec <- Logic_interp.formals_in_ensures kf) + (fun kf -> + Kernel_function.set_spec kf (fun _ -> Logic_interp.formals_in_ensures kf)) include Plugin.Register (struct @@ -12,6 +13,5 @@ let help = "test purposes only" let module_name = "Rewrite_ensures" end) -;; -Db.Main.extend rewrite;; +let () = Db.Main.extend rewrite diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/second.c frama-c-20111001+nitrogen+dfsg/tests/spec/second.c --- frama-c-20110201+carbon+dfsg/tests/spec/second.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/second.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,13 @@ +/ run.config + DONTRUN: linked with first which is the real test. +/ + +/@ behavior b: + requires \valid(second); + ensures \result == 0;/ +int bar(int second); + +void sub (char * c) { + bar(c); + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/stmt_contract.i frama-c-20111001+nitrogen+dfsg/tests/spec/stmt_contract.i --- frama-c-20110201+carbon+dfsg/tests/spec/stmt_contract.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/stmt_contract.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,11 @@ +int main(void) { + int x = 5, y = 2; + + /@ requires x == 5; / + /@ requires y == 2; / + x = x + y; + + /@ requires x == 7; / + /@ ensures x == 7; / + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/temporal.i frama-c-20111001+nitrogen+dfsg/tests/spec/temporal.i --- frama-c-20110201+carbon+dfsg/tests/spec/temporal.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/temporal.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,468 @@ +/* Generated by Frama-C */ +extern int g_calls ; +int g(int x ) ; +void h(void) ; +extern int random() ; +extern int NB ; +extern int G_i ; +enum aorai_States { + S5 = 4, + S4 = 6, + S3 = 5, + S2 = 3, + S1 = 0, + OK = 2, + S0 = 1 +} ; +//**************** +//* BEGIN Primitives generated for LTL verification +//* +//* States and Trans Variables +int aorai_CurStates[7] = {1, 0, 0, 0, 0, 0, 0}; +int aorai_CurTrans[9] = + {1, 0, 0, 0, 0, 0, 0, 0, 0}; +int aorai_CurStates_old[7] = {0, 1, 0, 0, 0, 0, 0}; +//* +//* +//* Some constants +enum aorai_ListOper { + op_g = 2, + op_f = 1, + op_h = 0 +} ; +enum aorai_ListOper aorai_CurOperation = op_f; +enum aorai_OpStatusList { + aorai_Terminated = 1, + aorai_Called = 0 +} ; +enum aorai_OpStatusList aorai_CurOpStatus = aorai_Called; +//* +//* Loops management +int aorai_Loop_Init_38 = 0; +//* +//**************** +//* Axiomatized transitions automata +/@ +axiomatic + aorai_Trans_Start { + logic integer aorai_Trans_Start(integer tr) ; + + axiom aorai_Trans_Start0: (aorai_Trans_Start(0) == 1); + + axiom aorai_Trans_Start1: (aorai_Trans_Start(1) == 0); + + axiom aorai_Trans_Start2: (aorai_Trans_Start(2) == 0); + + axiom aorai_Trans_Start3: (aorai_Trans_Start(3) == 3); + + axiom aorai_Trans_Start4: (aorai_Trans_Start(4) == 3); + + axiom aorai_Trans_Start5: (aorai_Trans_Start(5) == 3); + + axiom aorai_Trans_Start6: (aorai_Trans_Start(6) == 5); + + axiom aorai_Trans_Start7: (aorai_Trans_Start(7) == 6); + + axiom aorai_Trans_Start8: (aorai_Trans_Start(8) == 4); + + } + / +/@ +axiomatic + aorai_Trans_Stop { + logic integer aorai_Trans_Stop(integer tr) ; + + axiom aorai_Trans_Stop0: (aorai_Trans_Stop(0) == 0); + + axiom aorai_Trans_Stop1: (aorai_Trans_Stop(1) == 2); + + axiom aorai_Trans_Stop2: (aorai_Trans_Stop(2) == 3); + + axiom aorai_Trans_Stop3: (aorai_Trans_Stop(3) == 0); + + axiom aorai_Trans_Stop4: (aorai_Trans_Stop(4) == 4); + + axiom aorai_Trans_Stop5: (aorai_Trans_Stop(5) == 5); + + axiom aorai_Trans_Stop6: (aorai_Trans_Stop(6) == 6); + + axiom aorai_Trans_Stop7: (aorai_Trans_Stop(7) == 4); + + axiom aorai_Trans_Stop8: (aorai_Trans_Stop(8) == 2); + + } + / +/@ +predicate aorai_Trans_Cond_param{L}(integer _aorai_numTrans, integer + _aorai_op, integer _aorai_status) = + (((_aorai_numTrans == 0) ==> + ((_aorai_op == op_f) && (_aorai_status == aorai_Called))) + && + (((_aorai_numTrans == 1) ==> + (((_aorai_op == op_f) && (_aorai_status == aorai_Terminated)) && (NB <= 0))) + && + (((_aorai_numTrans == 2) ==> + (((((_aorai_op == op_g) && (_aorai_status == aorai_Called)) && (NB > 0)) && + (g_calls < NB)) + && (0 <= g_calls))) + && + (((_aorai_numTrans == 3) ==> + (((G_i == 0) && (g_calls < NB)) && + ((_aorai_op == op_g) && (_aorai_status == aorai_Terminated)))) + && + (((_aorai_numTrans == 4) ==> + (((G_i == 0) && (g_calls == NB)) && + ((_aorai_op == op_g) && (_aorai_status == aorai_Terminated)))) + && + (((_aorai_numTrans == 5) ==> + ((G_i != 0) && + ((_aorai_op == op_g) && (_aorai_status == aorai_Terminated)))) + && + (((_aorai_numTrans == 6) ==> + ((_aorai_op == op_h) && (_aorai_status == aorai_Called))) + && + (((_aorai_numTrans == 7) ==> + ((_aorai_op == op_h) && (_aorai_status == aorai_Terminated))) + && + ((_aorai_numTrans == 8) ==> + ((_aorai_op == op_f) && (_aorai_status == aorai_Terminated))))))))))); + / +/@ +predicate aorai_Trans_Cond{L}(integer _aorai_numTrans) = + aorai_Trans_Cond_param{L}(_aorai_numTrans, aorai_CurOperation, + aorai_CurOpStatus); + +/ +//* +//**************** +//* Safety invariants +//* +//* Inv 2.1 : Not crossable transitions (cond = false) are not crossed over +/@ +global +invariant _Buch_not_crossable_cond: + (\forall integer _buch_tr; + ((((0 <= _buch_tr) && (_buch_tr < 9)) && + !(aorai_Trans_Cond(_buch_tr))) + ==> (aorai_CurTrans[_buch_tr] == 0))); + +/ +//* Inv 2.2 : Not crossable transitions (start state not active) are not crossed over +/@ +global +invariant _Buch_not_crossable_start: + (\forall integer _buch_tr; + ((((0 <= _buch_tr) && (_buch_tr < 9)) && + (aorai_CurStates_old[aorai_Trans_Start + (_buch_tr)] + == 0)) + ==> (aorai_CurTrans[_buch_tr] == 0))); + / +//* Inv 4 : Each not reachable state is not reached +/@ +global +invariant _Buch_not_reachable: + (\forall integer _buch_st; + ((((0 <= _buch_st) && (_buch_st < 7)) && + (\forall integer _buch_tr; + (((0 <= _buch_tr) && (_buch_tr < 9)) ==> + ((aorai_CurTrans[_buch_tr] == 0) || + (aorai_Trans_Stop(_buch_tr) != _buch_st))))) + ==> (aorai_CurStates[_buch_st] == 0))); + +/ +//* +//* END Primitives generated for LTL verification +//**************** +/@ requires ((((((((0 == aorai_CurTrans[0]) && (0 == aorai_CurTrans[1])) && + (0 == aorai_CurTrans[3])) + && (0 == aorai_CurTrans[4])) + && (0 == aorai_CurTrans[5])) + && (0 == aorai_CurTrans[6])) + && (0 == aorai_CurTrans[7])) + && (0 == aorai_CurTrans[8])); + requires (0 != aorai_CurTrans[2]); + requires ((((((0 == aorai_CurStates[S1]) && (0 == aorai_CurStates[S0])) && + (0 == aorai_CurStates[OK])) + && (0 == aorai_CurStates[S5])) + && (0 == aorai_CurStates[S3])) + && (0 == aorai_CurStates[S4])); + requires (0 != aorai_CurStates[S2]); + requires ((aorai_CurTrans[2] != 0) ==> + (((NB > 0) && (g_calls < NB)) && (0 <= g_calls))); + behavior Buchi_property_behavior_3: + ensures (((aorai_CurTrans[5] != 0) ==> (G_i != 0)) && + (((aorai_CurTrans[4] != 0) ==> ((G_i == 0) && (g_calls == NB))) + && + ((aorai_CurTrans[3] != 0) ==> ((G_i == 0) && (g_calls < NB))))); + ensures ((((((0 == aorai_CurTrans[0]) && (0 == aorai_CurTrans[1])) && + (0 == aorai_CurTrans[2])) + && (0 == aorai_CurTrans[6])) + && (0 == aorai_CurTrans[7])) + && (0 == aorai_CurTrans[8])); + ensures (((0 != aorai_CurTrans[3]) || (0 != aorai_CurTrans[4])) || + (0 != aorai_CurTrans[5])); + ensures ((((0 == aorai_CurStates[S0]) && (0 == aorai_CurStates[OK])) && + (0 == aorai_CurStates[S2])) + && (0 == aorai_CurStates[S4])); + ensures (((0 != aorai_CurStates[S1]) || (0 != aorai_CurStates[S5])) || + (0 != aorai_CurStates[S3])); + + behavior default: + ensures (g_calls == \old(g_calls)+1); + assigns g_calls; + +/ +int g(int x ) +{ + int tmp ; + g_calls ++; + tmp = random(); + aorai_CurOperation = op_g; + aorai_CurOpStatus = aorai_Terminated; + aorai_CurStates_old[S5] = 0; + aorai_CurStates_old[S4] = 0; + aorai_CurStates_old[S3] = 0; + aorai_CurStates_old[S2] = aorai_CurStates[3]; + aorai_CurStates_old[S1] = 0; + aorai_CurStates_old[OK] = 0; + aorai_CurStates_old[S0] = 0; + aorai_CurTrans[0] = 0; + aorai_CurTrans[1] = 0; + aorai_CurTrans[2] = 0; + aorai_CurTrans[3] = (G_i == 0 && g_calls < NB) && aorai_CurStates_old[3]; + aorai_CurTrans[4] = (G_i == 0 && g_calls == NB) && aorai_CurStates_old[3]; + aorai_CurTrans[5] = G_i != 0 && aorai_CurStates_old[3]; + aorai_CurTrans[6] = 0; + aorai_CurTrans[7] = 0; + aorai_CurTrans[8] = 0; + aorai_CurStates[S5] = aorai_CurTrans[4]; + aorai_CurStates[S4] = 0; + aorai_CurStates[S3] = aorai_CurTrans[5]; + aorai_CurStates[S2] = 0; + aorai_CurStates[S1] = aorai_CurTrans[3]; + aorai_CurStates[OK] = 0; + aorai_CurStates[S0] = 0; + return (tmp); +} + +/@ requires ((((((((0 == aorai_CurTrans[0]) && (0 == aorai_CurTrans[1])) && + (0 == aorai_CurTrans[2])) + && (0 == aorai_CurTrans[3])) + && (0 == aorai_CurTrans[4])) + && (0 == aorai_CurTrans[5])) + && (0 == aorai_CurTrans[7])) + && (0 == aorai_CurTrans[8])); + requires (0 != aorai_CurTrans[6]); + requires ((((((0 == aorai_CurStates[S1]) && (0 == aorai_CurStates[S0])) && + (0 == aorai_CurStates[OK])) + && (0 == aorai_CurStates[S2])) + && (0 == aorai_CurStates[S5])) + && (0 == aorai_CurStates[S3])); + requires (0 != aorai_CurStates[S4]); + behavior Buchi_property_behavior_6: + ensures ((((((((0 == aorai_CurTrans[0]) && (0 == aorai_CurTrans[1])) && + (0 == aorai_CurTrans[2])) + && (0 == aorai_CurTrans[3])) + && (0 == aorai_CurTrans[4])) + && (0 == aorai_CurTrans[5])) + && (0 == aorai_CurTrans[6])) + && (0 == aorai_CurTrans[8])); + ensures (0 != aorai_CurTrans[7]); + ensures ((((((0 == aorai_CurStates[S1]) && (0 == aorai_CurStates[S0])) + && (0 == aorai_CurStates[OK])) + && (0 == aorai_CurStates[S2])) + && (0 == aorai_CurStates[S3])) + && (0 == aorai_CurStates[S4])); + ensures (0 != aorai_CurStates[S5]); + + behavior default: + assigns \nothing; + +/ +void h(void) +{ + aorai_CurOperation = op_h; + aorai_CurOpStatus = aorai_Terminated; + aorai_CurStates_old[S5] = 0; + aorai_CurStates_old[S4] = aorai_CurStates[6]; + aorai_CurStates_old[S3] = 0; + aorai_CurStates_old[S2] = 0; + aorai_CurStates_old[S1] = 0; + aorai_CurStates_old[OK] = 0; + aorai_CurStates_old[S0] = 0; + aorai_CurTrans[0] = 0; + aorai_CurTrans[1] = 0; + aorai_CurTrans[2] = 0; + aorai_CurTrans[3] = 0; + aorai_CurTrans[4] = 0; + aorai_CurTrans[5] = 0; + aorai_CurTrans[6] = 0; + aorai_CurTrans[7] = aorai_CurStates_old[6]; + aorai_CurTrans[8] = 0; + aorai_CurStates[S5] = aorai_CurTrans[7]; + aorai_CurStates[S4] = 0; + aorai_CurStates[S3] = 0; + aorai_CurStates[S2] = 0; + aorai_CurStates[S1] = 0; + aorai_CurStates[OK] = 0; + aorai_CurStates[S0] = 0; + return; +} + +/@ requires ((((((((0 == aorai_CurTrans[1]) && (0 == aorai_CurTrans[2])) && + (0 == aorai_CurTrans[3])) + && (0 == aorai_CurTrans[4])) + && (0 == aorai_CurTrans[5])) + && (0 == aorai_CurTrans[6])) + && (0 == aorai_CurTrans[7])) + && (0 == aorai_CurTrans[8])); + requires (0 != aorai_CurTrans[0]); + requires ((((((0 == aorai_CurStates[S0]) && (0 == aorai_CurStates[OK])) && + (0 == aorai_CurStates[S2])) + && (0 == aorai_CurStates[S5])) + && (0 == aorai_CurStates[S3])) + && (0 == aorai_CurStates[S4])); + requires (0 != aorai_CurStates[S1]); + behavior Buchi_property_behavior_0: + ensures ((aorai_CurTrans[1] != 0) ==> (NB <= 0)); + ensures (((((((0 == aorai_CurTrans[0]) && (0 == aorai_CurTrans[2])) && + (0 == aorai_CurTrans[3])) + && (0 == aorai_CurTrans[4])) + && (0 == aorai_CurTrans[5])) + && (0 == aorai_CurTrans[6])) + && (0 == aorai_CurTrans[7])); + ensures ((0 != aorai_CurTrans[1]) || (0 != aorai_CurTrans[8])); + ensures ((((((0 == aorai_CurStates[S1]) && (0 == aorai_CurStates[S0])) + && (0 == aorai_CurStates[S2])) + && (0 == aorai_CurStates[S5])) + && (0 == aorai_CurStates[S3])) + && (0 == aorai_CurStates[S4])); + ensures (0 != aorai_CurStates[OK]); + + +/ +void f(int N ) +{ + int i ; + int t ; + i = 0; + t = 0; + { /undefined sequence/ G_i = 0; g_calls = G_i; } + NB = N; + aorai_Loop_Init_38 = 1; + /@ loop invariant + ((((0 != aorai_CurStates[S1]) || (0 != aorai_CurStates[S5])) || + (0 != aorai_CurStates[S3])) + && + (((((0 == aorai_CurStates[S0]) && (0 == aorai_CurStates[OK])) && + (0 == aorai_CurStates[S2])) + && (0 == aorai_CurStates[S4])) + && + (((((0 != aorai_CurTrans[0]) || (0 != aorai_CurTrans[3])) || + (0 != aorai_CurTrans[4])) + || (0 != aorai_CurTrans[5])) + && + (((((0 == aorai_CurTrans[1]) && (0 == aorai_CurTrans[2])) && + (0 == aorai_CurTrans[6])) + && (0 == aorai_CurTrans[7])) + && (0 == aorai_CurTrans[8]))))); + loop invariant + ((aorai_Loop_Init_38 != 0) ==> + ((aorai_CurStates[4] == 0) && + ((aorai_CurStates[5] == 0) && + ((aorai_CurTrans[3] == 0) && + ((aorai_CurTrans[4] == 0) && (aorai_CurTrans[5] == 0)))))); + loop invariant ((aorai_Loop_Init_38 == 0) ==> (aorai_CurTrans[0] == 0)); + / + while (1) { + if (i < N) { if (! (! t)) { goto while_0_break; } } + else { goto while_0_break; } + aorai_Loop_Init_38 = 0; + aorai_CurOperation = op_g; + aorai_CurOpStatus = aorai_Called; + aorai_CurStates_old[S5] = 0; + aorai_CurStates_old[S4] = 0; + aorai_CurStates_old[S3] = 0; + aorai_CurStates_old[S2] = 0; + aorai_CurStates_old[S1] = aorai_CurStates[0]; + aorai_CurStates_old[OK] = 0; + aorai_CurStates_old[S0] = 0; + aorai_CurTrans[0] = 0; + aorai_CurTrans[1] = 0; + aorai_CurTrans[2] = ((NB > 0 && g_calls < NB) && 0 <= g_calls) && aorai_CurStates_old[0]; + aorai_CurTrans[3] = 0; + aorai_CurTrans[4] = 0; + aorai_CurTrans[5] = 0; + aorai_CurTrans[6] = 0; + aorai_CurTrans[7] = 0; + aorai_CurTrans[8] = 0; + aorai_CurStates[S5] = 0; + aorai_CurStates[S4] = 0; + aorai_CurStates[S3] = 0; + aorai_CurStates[S2] = aorai_CurTrans[2]; + aorai_CurStates[S1] = 0; + aorai_CurStates[OK] = 0; + aorai_CurStates[S0] = 0; + t = g(i); + G_i = t; + i ++; + g_calls = i; + } + while_0_break: /* internal / ; + if (t) { + aorai_CurOperation = op_h; + aorai_CurOpStatus = aorai_Called; + aorai_CurStates_old[S5] = 0; + aorai_CurStates_old[S4] = 0; + aorai_CurStates_old[S3] = aorai_CurStates[5]; + aorai_CurStates_old[S2] = 0; + aorai_CurStates_old[S1] = 0; + aorai_CurStates_old[OK] = 0; + aorai_CurStates_old[S0] = 0; + aorai_CurTrans[0] = 0; + aorai_CurTrans[1] = 0; + aorai_CurTrans[2] = 0; + aorai_CurTrans[3] = 0; + aorai_CurTrans[4] = 0; + aorai_CurTrans[5] = 0; + aorai_CurTrans[6] = aorai_CurStates_old[5]; + aorai_CurTrans[7] = 0; + aorai_CurTrans[8] = 0; + aorai_CurStates[S5] = 0; + aorai_CurStates[S4] = aorai_CurTrans[6]; + aorai_CurStates[S3] = 0; + aorai_CurStates[S2] = 0; + aorai_CurStates[S1] = 0; + aorai_CurStates[OK] = 0; + aorai_CurStates[S0] = 0; + h(); + } + aorai_CurOperation = op_f; + aorai_CurOpStatus = aorai_Terminated; + aorai_CurStates_old[S5] = aorai_CurStates[4]; + aorai_CurStates_old[S4] = 0; + aorai_CurStates_old[S3] = 0; + aorai_CurStates_old[S2] = 0; + aorai_CurStates_old[S1] = aorai_CurStates[0]; + aorai_CurStates_old[OK] = 0; + aorai_CurStates_old[S0] = 0; + aorai_CurTrans[0] = 0; + aorai_CurTrans[1] = NB <= 0 && aorai_CurStates_old[0]; + aorai_CurTrans[2] = 0; + aorai_CurTrans[3] = 0; + aorai_CurTrans[4] = 0; + aorai_CurTrans[5] = 0; + aorai_CurTrans[6] = 0; + aorai_CurTrans[7] = 0; + aorai_CurTrans[8] = aorai_CurStates_old[4]; + aorai_CurStates[S5] = 0; + aorai_CurStates[S4] = 0; + aorai_CurStates[S3] = 0; + aorai_CurStates[S2] = 0; + aorai_CurStates[S1] = 0; + aorai_CurStates[OK] = aorai_CurTrans[8] || aorai_CurTrans[1]; + aorai_CurStates[S0] = 0; + return; +} + diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/third.c frama-c-20111001+nitrogen+dfsg/tests/spec/third.c --- frama-c-20110201+carbon+dfsg/tests/spec/third.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/third.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,10 @@ +/ run.config + DONTRUN: linked with first which is the real test. +/ +/@ behavior b: + requires \valid(third); + ensures \result == 0;/ +int bar(int third) { + third=(int)third; + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/type_of_term.i frama-c-20111001+nitrogen+dfsg/tests/spec/type_of_term.i --- frama-c-20110201+carbon+dfsg/tests/spec/type_of_term.i 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/type_of_term.i 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,16 @@ +/* run.config + OPT: -load-script tests/spec/type_of_term.ml -print +/ + +int t [42]; + +struct S { int x; int y[]; } s; + +/@ assigns (p+(..)), t[..], s[..].x, s[..].y[..]; +/ +void f(int p, struct S s); + +int main() { + f(t,&s); + return 0; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/type_of_term.ml frama-c-20111001+nitrogen+dfsg/tests/spec/type_of_term.ml --- frama-c-20110201+carbon+dfsg/tests/spec/type_of_term.ml 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/type_of_term.ml 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,36 @@ +open Cil_types + +include Plugin.Register + (struct + let name = "type_of_term" + let shortname = "type_of_term" + let help = "checks typeOfTermLval over sets" + end) + +class visitor = + object + inherit Visitor.frama_c_inplace + method vterm t = + result "Term: %a, type is %a" + !Ast_printer.d_term t !Ast_printer.d_logic_type t.Cil_types.term_type; + Cil.DoChildren + method vterm_lval (host,off as lv) = + let ty = Cil.typeOfTermLval lv in + let plain_lval = (host,TNoOffset) in + let tyh = Cil.typeOfTermLval plain_lval in + let tyoff = Cil.typeTermOffset tyh off in + result "Host: %a, type is %a" + !Ast_printer.d_term_lval plain_lval !Ast_printer.d_logic_type tyh; + result "Offset: %a, type is %a" + !Ast_printer.d_term_offset off !Ast_printer.d_logic_type tyoff; + result "Lval: %a, type is %a" + !Ast_printer.d_term_lval lv !Ast_printer.d_logic_type ty; + Cil.DoChildren + end + +let run () = + let ast = Ast.get () in + Visitor.visitFramacFileSameGlobals (new visitor) ast +;; + +Db.Main.extend run diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/use2.c frama-c-20111001+nitrogen+dfsg/tests/spec/use2.c --- frama-c-20110201+carbon+dfsg/tests/spec/use2.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/use2.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,8 @@ +/* run.config + DONTRUN: main test is in use.c +/ + +#include "tests/spec/dec.h" + +//@ ensures X > 0 ; ensures F(1)>0 ; +void g(void) {} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/use.c frama-c-20111001+nitrogen+dfsg/tests/spec/use.c --- frama-c-20110201+carbon+dfsg/tests/spec/use.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/use.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,10 @@ +/ run.config + STDOPT: +"tests/spec/use2.c" +/ + +// BTS 0887 + +#include "tests/spec/dec.h" + +//@ ensures X > 0 ; ensures F(1) > 0 ; +void f(void) {} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/va.c frama-c-20111001+nitrogen+dfsg/tests/spec/va.c --- frama-c-20110201+carbon+dfsg/tests/spec/va.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/va.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,8 @@ +#include "../../share/libc/stdio.h" + +void main(int x, ...) { + int x,y; + va_list p; + va_start(p,x); + vscanf("FOO %d %d",p); +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/volatile_aux.c frama-c-20111001+nitrogen+dfsg/tests/spec/volatile_aux.c --- frama-c-20110201+carbon+dfsg/tests/spec/volatile_aux.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/volatile_aux.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,11 @@ +/ run.config + DONTRUN: main test file is volatile.c +/ + +#include "tests/spec/volatile.h" + +int f (int x) { + x++; + v = x; + return v+x; +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/volatile.c frama-c-20111001+nitrogen+dfsg/tests/spec/volatile.c --- frama-c-20110201+carbon+dfsg/tests/spec/volatile.c 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/volatile.c 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,20 @@ +/ run.config + OPT: tests/spec/volatile_aux.c -print -check -copy +/ + +#include "tests/spec/volatile.h" +const int c = 1 ; +volatile int v ; +int p; +//@lemma comp_const_addr: p==&c; +//@lemma comp_volatile_addr: p==&v; +//@lemma volatile_in_annot_is_illegal: v == 1 ==> v==1; + +int main () { + + int x = v; + v = f(x); + + return 0; + +} diff -Nru frama-c-20110201+carbon+dfsg/tests/spec/volatile.h frama-c-20111001+nitrogen+dfsg/tests/spec/volatile.h --- frama-c-20110201+carbon+dfsg/tests/spec/volatile.h 1970-01-01 00:00:00.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/spec/volatile.h 2011-10-10 08:38:50.000000000 +0000 @@ -0,0 +1,22 @@ +typedef volatile int VINT; + +extern int f(int); + +inline int r(VINT* v) { return v; } + +inline int w(volatile int v, int new) { v = new; return new; } + +volatile int v, tab[10]; +VINT pt; + +struct st { int a ; volatile int v ; } s ; +//@ volatile v, tab[..] reads r writes w; +//@ volatile pt writes w; +//@ volatile s.v reads r; + +typedef struct st ST ; +struct vst { int b ; ST v ; } vs ; +// some parts of vs have volatile qualifier +struct vst rs (struct vst p) ; +struct vst ws (struct vst * p, struct vst v) ; +//@volatile vs reads rs writes ws ; diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/access.c frama-c-20111001+nitrogen+dfsg/tests/wp/access.c --- frama-c-20110201+carbon+dfsg/tests/wp/access.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/access.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -/* - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Out of Scope - / - - - - -struct Tb { int b ; } ; -struct Ta { - struct Tb a ; -} x ; - - -/@ requires \valid((x.a+i)) ; - ensures x.a[i].b == v; - ensures (((x.a)+i)).b == x.a[i].b ; / -int main (int i, int v) { - (((x.a)+i)).b = v+1 ; - x.a[i].b = v; - return 1; -} - - - -int p; -/@ ensures p == 0; -/ -void main2 () { - int tmp; - p = 0; - tmp=1; -} - -int j; -//@ ensures \result == 4; -int * result_offset_val (void) -{ - int p; - p = &j; - j=4; - return p; -} - - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/AddressTestPos.c frama-c-20111001+nitrogen+dfsg/tests/wp/AddressTestPos.c --- frama-c-20110201+carbon+dfsg/tests/wp/AddressTestPos.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/AddressTestPos.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -/ - kind : Positive - model name : Store; bhv : Provable - model name : Hoare; bhv : Out of Scope -/ - -int t[2]; - -//@ ensures (t[0])== 4; -int main() -{ - - int i=4; - int j=3; - int p; - int * q; - - p = &i ; - q = &j; - t[0]= p; - t[1]= q; - return 0; - -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/addrof.c frama-c-20111001+nitrogen+dfsg/tests/wp/addrof.c --- frama-c-20110201+carbon+dfsg/tests/wp/addrof.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/addrof.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -/* - kind : Positive - model name : Store ; bhv : Proved with alt_ergo - model name : Hoare ; bhv : Out of Scope - / -int A; - -/@ ensures A == 5 ; / -int main() { - int p = &A; - p = 5; - return p; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/adjacent_find.c frama-c-20111001+nitrogen+dfsg/tests/wp/adjacent_find.c --- frama-c-20110201+carbon+dfsg/tests/wp/adjacent_find.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/adjacent_find.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -/* - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Out of Scope - / - - -/@ - predicate is_valid_int_range(int* p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ - -/@ - predicate - adjacent_found{Label}(int* a, int n) = - \exists int i; 0 <= i < n-1 && a[i] == a[i+1]; -/ - -/@ - requires is_valid_int_range(a, n); - - assigns \nothing; - - behavior some: - assumes adjacent_found(a, n); - ensures 0 <= \result < n-1; - ensures a[\result] == a[\result+1]; - ensures !adjacent_found(a, \result); - - behavior none: - assumes !adjacent_found(a, n); - ensures \result == n; - - complete behaviors some, none; - disjoint behaviors some, none; -/ -int adjacent_find(int a, int n) -{ - if (0 == n) return n; - - /@ - loop assigns i; - loop invariant 0 <= i < n; - loop invariant !adjacent_found(a, i); - loop invariant 0 a[i-1] != a[i]; - loop variant n-i; - / - for (int i = 0; i < n-1; i++) - if (a[i] == a[i+1]) - return i; - - return n; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/ArrayTest.c frama-c-20111001+nitrogen+dfsg/tests/wp/ArrayTest.c --- frama-c-20110201+carbon+dfsg/tests/wp/ArrayTest.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/ArrayTest.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -/* - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Out of Scope - / - -int x[2][3][5] = - { - {{ 111,112,113,114,115 }, - { 121,122,123,124,125 }, - { 131,132,133,134,135 }} , - {{ 211,212,213,214,215 }, - { 221,222,223,224,225 }, - { 231,232,233,234,235 }} - }; - -int p1; -int p2; -int p3; - -int x1; -int x2; -int x3; - -/@ - ensures x1 == 211 ; - ensures x2 == 212 ; - ensures x3 == 123 ; -/ -void main () { - - p1 = (int )(x+1); - x1 = (p1); - - p2 = p1+1; - x2 = p2; - - p3 = x[0][1]+2; - x3 = p3; - -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/AssignsLoop.c frama-c-20111001+nitrogen+dfsg/tests/wp/AssignsLoop.c --- frama-c-20110201+carbon+dfsg/tests/wp/AssignsLoop.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/AssignsLoop.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -/* - kind : Positive - model name : Store ; bhv : Not Sure About - model name : Hoare ; bhv : Not Sure About - / - -int r; - -//@ requires i==1; ensures r==3; -void no_loop_assigns (int i) -{ - while(i!=4) {r=i ; i++;} -} - -//@ requires i==1; ensures r==3; -void loop_with_assigns (int i) -{ - //@ loop assigns r,i; - while(i!=4) {r=i ; i++;} -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/assigns_meth.c frama-c-20111001+nitrogen+dfsg/tests/wp/assigns_meth.c --- frama-c-20110201+carbon+dfsg/tests/wp/assigns_meth.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/assigns_meth.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -/ - run.config - OPT: -wp-proof none -wp-print -wp-prop assigns -wp-assigns memory - OPT: -wp-proof none -wp-print -wp-prop assigns -wp-assigns effect -/ - - - -//@ predicate P (integer i) = i >= 0; - -int t [4]; -int a,b ; - -/@ - requires P(a); - assigns a , b, t[0..2] ; - ensures P(b); - / -void f (void){ - - a =0 ; b =0 ; - t[0] = 0 ; - t[1] = 0; - t[2] = 2; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/AssignsTestPos1.c frama-c-20111001+nitrogen+dfsg/tests/wp/AssignsTestPos1.c --- frama-c-20110201+carbon+dfsg/tests/wp/AssignsTestPos1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/AssignsTestPos1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -/ - kind : Positive - model name : Store ; bhv : Proved with alt_ergo - model name : Hoare ; bhv : Proved with all - / - -//@ assigns \nothing; -int assigns_nothing(void) -{ return 5; -} - -int r,g; - -// two tset -//@ assigns r,g ; -void assigns_two_loc(void) -{ r=5; g=8;} - -//@ assigns \union(r,g) ; -void assigns_union_of_two_loc(void) -{ r=1; g=2;} - -//@ assigns r; -void assigns_no_cst(void) -{ r=g;} - - -/@ - behavior NULL : assumes i==0; assigns r; - behavior OTHER : assumes i!=0;assigns \nothing; - / -void assigns_cond(int i) -{ - if (i==0) r=12 ; -} - -//@ requires i>0; ensures i>0; -void no_assigns (int i) -{ - if (i==0) r=12 ; -} - -int main (void) {return 0;} - - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/assigns_tests.c frama-c-20111001+nitrogen+dfsg/tests/wp/assigns_tests.c --- frama-c-20110201+carbon+dfsg/tests/wp/assigns_tests.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/assigns_tests.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -/ - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Out of Scope - / -/@ ensures x == 3; - assigns x; - / -void ptr_deref_assigns (int x) { - x = 3; -} - - -int p; -int a; - -//@ assigns p, p , a ; -/ CORRECT / -void ptr_deref_ptr_assigns_1 (void) -{ - p = &a; - p = 5; -} - -//@ assigns p,p; -/ CORRECT, because ensures p == &a / -void ptr_deref_ptr_assigns_2 (void) -{ - p = &a; - p = 5; -} - -//@ assigns p; -/* INCORRECT, because missing a / -void ptr_deref_ptr_assigns_3 (void) -{ - p = &a; - p = 5; -} - -//@ assigns p , \old(p); -/ CORRECT / -void deref_ptr_ptr_assigns_1 (void) -{ - p=5; - p=&a; -} - -//@ assigns p , p; -/ INCORRECT sauf si \old(p==&a) / -void deref_ptr_ptr_assigns_2 (void) -{ - p=5; - p=&a; -} - - -int main () { return 0;} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/axioms.c frama-c-20111001+nitrogen+dfsg/tests/wp/axioms.c --- frama-c-20110201+carbon+dfsg/tests/wp/axioms.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/axioms.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -/* run.config - OPT: -wp -wp-assigns effect -wp-axioms -wp-print -/ -/ run.config_why - OPT: -wp -wp-assigns effect -wp-axioms -wp-timeout 5 -wp-proof alt-ergo -wp-par 1 - -/ - -// Test for the instanciation of axioms with labels. -// The axiomatic A is equivalent (in spirit) to the definition of predicate Q. -// Both should be provable with alt-ergo immediately, under the hypothesis of the loop-assign. -// This last property can be discharged in Coq with the provided proof. - - -/@ axiomatic A { - @ predicate P{L}(int t,int a,int b) reads t ; - @ axiom D{L}: - @ \forall int * t ; \forall int a,b ; - @ (\forall int k ; a<=k<=b ==> \valid(t+k) ==> t[k] > 0) ==> P(t,a,b) ; - @ } - @ / - -/@ predicate Q(int t,int a,int b) = - @ \forall int k ; a<=k<=b ==> \valid(t+k) ==> t[k] > 0 ; - @ / - - -/@ requires \valid(t+(a..b)) ; - @ ensures P : P(t,a,b) ; - @ ensures Q : Q(t,a,b) ; - @ assigns t[a..b] ; - @ / - -void f(int t , int a, int b) -{ - - /@ loop invariant Index: a<=i<=b+1 ; - @ loop invariant Positive: \forall int k ; a<=k t[k] > 0 ; - @ loop assigns i,t[a..i-1] ; - @ / - for(int i=a; i<=b; i++) t[i] = 1 ; - -} - -/ -------------------------------------------------------------------------- / -/ --- Coq Proof for loop assigns --- / -/ -------------------------------------------------------------------------- / - -/ -Proof. -intros. unfold ze1. apply inc_union_left. -rewrite right_empty. unfold ze0. unfold ze. -repeat ( try rewrite union_assoc ; try rewrite right_empty ; try rewrite left_empty ). -apply inc_union_union. - apply inc_same. - apply inc_union_left. unfold address_zone. unfold address_range. - repeat (try rewrite addr_base ; try repeat rewrite addr_offset ; repeat rewrite addr_sizeof ). - rewrite inc_range_range. intros. split. auto. split. omega. unfold i. omega. - unfold address_zone. unfold address_range. - repeat (try rewrite addr_base ; try repeat rewrite addr_offset ; try rewrite addr_sizeof). - rewrite inc_range_range. intros. split. - unfold address_shift. rewrite addr_base. auto. split. unfold address_shift. - rewrite addr_offset. omega. unfold address_shift. rewrite addr_offset. unfold i. omega. - rewrite right_empty. apply inc_union_right. left. apply inc_same. -Save. -/ - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bhv_for_code_annot.c frama-c-20111001+nitrogen+dfsg/tests/wp/bhv_for_code_annot.c --- frama-c-20110201+carbon+dfsg/tests/wp/bhv_for_code_annot.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bhv_for_code_annot.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -int Tab[10]; -/@ requires n < 10 ; - behavior foo: - assumes reset; - assigns Tab[0..n-1]; - behavior bar: - assumes !reset; - assigns \nothing; -/ -int h(int reset, int n) { - int i, r = 0 ; - /@ - for foo: - loop assigns Tab[0..i]; - for bar: - loop assigns \nothing; - / - for (i = 0 ; i < n ; i++) { - r += Tab[i] ; - if (reset) - Tab[i] = 0 ; - } - return r ; -} - -// Notice that even if g() assigns nothing, it still return an unknown result. -/@ - assigns \nothing; -/ -int g(); - -/@ assigns \nothing ; - ensures (reset?\result == 3 : \result == 2); - behavior foo: - assumes reset; ensures \result==3; - behavior bar: - assumes !reset; ensures \result == 2; -/ -int f (int reset) -{ - int r=2; - if(reset){ - r= g(); - //@ assert r == 3; - } - return r; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bidim_array.c frama-c-20111001+nitrogen+dfsg/tests/wp/bidim_array.c --- frama-c-20110201+carbon+dfsg/tests/wp/bidim_array.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bidim_array.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -/ - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Out of Scope - / - -int a[5][10] = {0, }; - -/@ assigns a[..][..]; - ensures a[1][3] == 42; - / -void f(void) -{ - a[1][3] = 42; -} - -int x[3][3] = { {1, 2, 3} , {4, 5, 6} , {7, 8, 9} }; - -//@ requires x[0][1] == 2; ensures \result == 2; -int f0 (void) { - int p = &(x[0][0]); - p++; - return p; -} - -//@ requires x[1][0] == 4; ensures \result == 4; -int f1 (void) { - int (pt)[3] = x; - pt++; - return (pt)[0]; -} -//@ requires x[1][1] == 5; ensures \result == 5; -int f2 (void) { - int (pt)[3] = x + 1; - int * p = (pt) + 1; - return p; -} - -//@ requires x[0][1] == 2; ensures \result == 2; -int read_tab (void) { - return x[0][1]; -} - -int main (void){return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bresenham.c frama-c-20111001+nitrogen+dfsg/tests/wp/bresenham.c --- frama-c-20110201+carbon+dfsg/tests/wp/bresenham.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bresenham.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -/**************************************************************************/ -/* / -/ Proof of the Bresenham line drawing algorithm. / -/ (see examples/bresenham/ for the Why proof) / -/ / -/ Jean-Christophe Filli�tre (LRI, Universit� Paris Sud) / -/ June 2008 / -/ */ -/**************************************************************************/ - -int x2, y2; - -/@ axiomatic Abs { - @ logic integer abs(integer x); - @ axiom abs_def: - @ \forall integer x; - @ (x >= 0 && abs(x) == x) || (x <= 0 && abs(x) == -x); - @ } - @/ - -/@ predicate best(integer x2,integer y2,integer x, integer y) = - @ \forall integer yp; abs(x2 y - x * y2) <= abs (x2 * yp - x * y2) - @ ; / - -/@ predicate Invariant(integer x2,integer y2,integer x, integer y, integer e) = - @ e == 2 * (x + 1) * y2 - (2 * y + 1) * x2 && - @ 2 * (y2 - x2) <= e <= 2 * y2 - @ ; / - -/@ lemma invariant_is_ok : - @ \forall integer x2,y2,x, y, e; Invariant(x2,y2,x,y,e) ==> best(x2,y2,x,y); - @/ - -//@ lemma z_ring_0 : \forall integer a, b, c; a (b+c) == ab + ac; -//@ lemma z_ring_1 : \forall integer a, b, c; (b+c) * a == ba + ca; - -//@requires 0 <= y2 <= x2; -void bresenham() { - int x = 0; - int y = 0; - int e = 2 * y2 - x2; - /@ loop invariant INV: 0 <= x <= x2 + 1 && Invariant(x2,y2,x,y,e); - @/ - for (x = 0; x <= x2; x++) { - // plot (x,y) at this point - //@ assert BEST: best(x2,y2,x,y); - if (e < 0) - e += 2 * y2; - else { - y++; - e += 2 * (y2 - x2); - } - } -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0055.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0055.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0055.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0055.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -int T[10]; - -// acces to (\result) -/@ requires 0 <= x < 10; - ensures \result == x && \base_addr (\result) == \base_addr(T); - assigns T[x]; -/ -int * ret_ptr (int x) { - T[x] = x; - return T+x; -} - -//@ ensures \result == 0; -int call_ret_ptr (void) { - int * p = ret_ptr (0); - return p; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0056.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0056.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0056.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0056.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -int T[10]; - -// -// loop assigns not translatable to C lval - -/@ assigns T[0..4]; - ensures T[5] == \old(T[5]); -/ -void assign_T (void) { - int i; - /@ loop assigns i, T[0..4]; - @ loop invariant 0 <= i; - / - for (i = 0; i < 5; i++) { - T[i] ++; - } -} -// -struct Ts { int a; int t[10]; }; -struct Ts S; - -//@ ensures (T[5] == \old(T[5])) && (S.a == \old(S.a)); -void assign_S (void) { - int i; - //@ loop assigns i, S; - for (i = 0; i < 5; i++) { - S.t[i] = T[i]; - } -} -// - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0057.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0057.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0057.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0057.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ - -// generated assigns contains not handled \at(\result, Post) -int g (int); - -int f (int x) { - return g (x); -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0058.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0058.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0058.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0058.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -int T[10]; - -// -// loop assigns can specify a loop invariant - -//@ ensures T[5] == \old(T[5]); -void assign_T (void) { - int i; - /@ loop assigns i, T[0..i-1]; - @ loop invariant 0 <= i <= 5; - / - for (i = 0; i < 5; i++) { - T[i] ++; - } - //@ assert i==5; -} -// -void assign_to_inv (void) { - int i; - /@ loop invariant 0 <= i; - @ loop invariant \forall int j; j > i-1 ==> T[j] == \at(T[j], Pre); - @ loop assigns i, T[0..4]; - / - for (i = 0; i < 5; i++) { - T[i] ++; - } -} -//~~~~~~~~~~ - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0085.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0085.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0085.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0085.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,135 +0,0 @@ -/ run.config_pruntime - OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-proof z3 -wp-print -wp-verbose 2 - OPT: -wp -wp-model Runtime -wp-logicvar -journal-disable -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -int P; -int X; - -/@ requires \valid (P); - ensures \result == 0; - / -// how can we say that if \valid (P), P cannot point on local variable x... -int ptr_glob_on_loc (void) { - int x = 0; - P = 3; - return x; -} - -/@ behavior ok: - assumes \valid (P); - ensures \old(P) == P; - @ behavior logicvar: - // LC: with -wp-logicvar, we have the implicit property that - // local variables never escape the call-frame ; hence we - // have separated(&x,p). See ptr_param_vs_glob function below. - // Hence, the goal should be proved with -wp-logicvar - ensures \old(P) == P; - / -int ptr_glob_on_loc_2 (void) { - int x = 0; - return x; -} - -/@ requires \valid (p); - @ ensures \result == 0; - / -int ptr_param_on_loc (int p) { - int x = 0; - p = 3; - return x; -} - -/@ behavior ok: - assumes \valid (p); - ensures \old(p) == p; - @ behavior logicvar: - // LC: with -wp-logicvar, we have the implicit property that - // local variables never escape the call-frame ; hence we - // have separated(&x,p). See ptr_param_vs_glob function below. - // Hence, the goal should be proved with -wp-logicvar - ensures \old(p) == p; - / -int ptr_param_on_loc_2 (int p) { - int x = 0; - return x; -} - -/@ requires \valid (P); - @ ensures \result == 0; - / -int ptr_glob_on_param (int x) { - x = 0; - P = 3; - return x; -} - -/@ requires \valid (p); - @ ensures \result == 0; - / -int ptr_param_on_param (int p, int x) { - x = 0; - p = 3; - return x; -} - -/@ ensures \result == 3; - / -int addr_loc_vs_addr_loc (void) { - int x, y; - x = 0; - y = 3; - return x + y; -} - -/@ ensures \result == 3; - / -int addr_loc_vs_addr_param (int x) { - int y; - x = 0; - y = 3; - return x + y; -} - -/@ ensures \result == 3; - / -int addr_loc_vs_addr_glob (void) { - int y; - X = 0; - y = 3; - return X + y; -} - -/@ ensures \result == 3; - / -int addr_param_vs_addr_glob (int x) { - x = 0; - X = 3; - return x + X; -} - -//@ ensures ! \valid(P); -void invalid_local_addr (void) { - int x; - P = &x; -} - -//@ ensures ! \valid(P); -void invalid_param_addr (int x) { - P = &x; -} - -/@ requires \valid (P); / -void disj_glob_addr_param (int x) { - //@ assert (P != &x); -} - -/@ ensures ok: \separated (p, &X) ==> X == \old(X); - ensures ko: X == \old(X); -/ -int ptr_param_vs_glob (int p) { - p = 0; - return p; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0093.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0093.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0093.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0093.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -/@ ensures x == 3; - assigns x; - / -void f (int * x) { - x = 3; -} - -//@ ensures \result == 3; -int g_loc (void) { - int x; - f (&x); - return x; -} -//@ ensures \result == 3; -int g_param (int x) { - f (&x); - return x; -} - -// don't define 'x' as a global variable because CIL then renames other 'x' -// and it hides the problem. -int y; - -//@ ensures y == 3; -void fy (int * y) { - y = 3; -} - -//@ ensures y == 3; -void g_glob (void) { - f (&y); -} -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0269.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0269.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0269.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0269.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -/ -------------------------------------------------------------------------- / -/ --- NON CONCLUSIVE TEST --- / -/ -------------------------------------------------------------------------- / -// WP aborts because logic variable S0 appears to be typed 'void' by CIL -// BTS #428 -/ -------------------------------------------------------------------------- / - -typedef struct _S S; -/@ axiomatic A { -logic S S0; -logic S S1(integer e); -logic S S2(S seq, integer e); - -axiom A1: \forall integer e; S1(e)!=S0; -axiom A2: \forall integer e1,e2; S1(e1)==S1(e2) <==> e1==e2; -axiom A3: \forall integer e; S1(e)==S2(S0,e); -axiom A4: \forall integer e1,e2, S s1,s2; S2(s1,e1)==S2(s2,e2) <==> (s1==s2&&e1==e2); -} / - -S s; - -//@ ensures s==S2(\old(s),e); -extern void g(const int e); - -/@ requires s==S0; - @ ensures s==S1(1); - @/ -void f1(void) { - g(1); -} -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0281.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0281.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0281.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0281.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -/ run.config_pruntime -OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-verbose 2 -wp-proof z3 - - / - -typedef int TAB32[32]; -TAB32 tab[32]; -int p = &tab[0][0]; - -/@ requires p == &tab[0][0] ; - ensures \true ; -/ -int main() { - return 1 ; -} - -//@ ensures \result == 1; -int f (void) { - int x = 1; - // check if M2 detects that it doesn't know how to do this : - ((int )(0x1234)) = 3; - return x; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0286.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0286.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0286.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0286.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ - -int cpt0 ; - -/@ -requires cpt0==0; -ensures \false ; -/ -void exit (int status); - -int cpt1 ; -extern int tab1[] ; - -/@ -requires cpt1==0; -assigns tab1[..] ; -/ -void f1 (int arg); - -/@ -requires cpt0==0; -requires cpt1==0; -ensures \false ; -/ -void g (int x) { - f1(4); - exit(1); -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0287.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0287.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0287.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0287.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ - -int s ; -//@ assigns s; -void g(int x); -//@ assigns s ; //<- doit �tre prouvable -void f(void) { - g(1); -} -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0288.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0288.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0288.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0288.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -int cpt, loc, p ; -/@ assigns p[..], cpt ; - ensures \forall int * q ; q != &cpt ==> q == \old(q); - ensures \forall int * q ; q == &loc ==> q == \old(q); -/ -void f1(int x) { - p[1] = x ; - cpt = 1; -} -/ -Proof. -intros. -subst mem_379. -subst q_370. -rewrite acc_upd_disj; - [ | apply disj_base; rewrite base_id_cpt; rewrite base_id_loc; auto with zarith]. -subst mem_383. - -rename mem_386 into m. -rename addr_x_381 into ad_x. - -1 subgoal -m : memory -ad_x : pointer Z -H : int_base_addr ad_x = 368 -______________________________________(1/1) -acc (upd m (shift_pointer (acc m addr_p_382) 1) (acc m ad_x)) addr_loc_374 = -acc m addr_loc_374 -/ - -/~ autres essais ~/ - -/ This property is nor true because we don't know if (&loc # p) / -/@ ensures \forall int * q ; q == &loc ==> q == \old(q); -/ -void f2 (void) { - p[1] = 0; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0295.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0295.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0295.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0295.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ - -int i=0; - -/@ requires i==0; - / -int f(void); - -int main() -{ - //@ assert i==0; - return f(); -} - -int X = 3; -int Y = X+1; - -//@ ensures \result == 4; -int other_main (void) { - return Y; -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0350.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0350.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0350.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0350.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -struct Ts {int x; int y; }; -struct Tstr {int a; struct Ts s; int t[10]; struct Tstr p; } S; - -/@ requires S.p == &S || \separated (S.p, &S); - @ ensures S.p->a == x ; - @ ensures \forall int i; ((S.p)).t[i] == \old(((S.p)).t[i]); - / - -void rw_ptr_field(int x ) -{ - (S.p)->a = x; - return; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0351.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0351.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0351.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0351.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -struct Ts {int x; int y; }; -struct Tstr {int a; struct Ts s; int t[10]; struct Tstr * p; } S; - -//@ ensures S.s.x == x && S.s == { \old(S.s) \with .x = x }; -void rw_field_field (int x) { - S.s.x = x; -} -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0352.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0352.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0352.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0352.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -int G; - -/@ behavior default: - ensures \separated(\result, &G); -/ -int ptrX(int p ) -{ - p = & G; - return (p); -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0352_false.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0352_false.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0352_false.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0352_false.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -int G; -int X; - - - -/@ behavior default: - ensures \separated(\result, &X); -/ -int ptrX(int p ) -{ - p = & G; - return (p); -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0354.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0354.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0354.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0354.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ - -union U { int a; int b; char c; } Gu; -union U Ggu; -void fu2 () { - Gu.a = 0; - Gu.b = 1; - //@ assert Gu.a == 1; - // this one is ok but need M3 (or maybe M2 ???) - //@ assert Gu.a == 0; - // the last one is false ! - Gu.c = 2; - Ggu.a=0; - Ggu.b=1; - Ggu.c = 2; - // //@ assert SI_PAS_PADDING : Ggu==Gu; // <--- doit être prouvable -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0355.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0355.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0355.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0355.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -int * P; -int X; -/@ requires \separated(P, &X); - behavior default: ensures (P > X); / -void f_with_hyp(void) -{ - int x ; - x = X; - P = x + 1; - return; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0356.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0356.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0356.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0356.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -/@ requires \valid_range(p,0,i); - behavior default: ensures (\old(p)[i] == 78); / -void main(int p , int i ) -{ - p ++; p ++; p ++; ((p + i) - 3) = 78; - return; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0427.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0427.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0427.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0427.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -#include <stddef.h> - -typedef struct stack_t { - int data; - unsigned long size; - unsigned long used; -} stack_t; - -void stack_init (stack_t , int , unsigned long); -int stack_valid (const stack_t stack); -int stack_push (stack_t , int); -int stack_pop (stack_t , int ); - -/@ predicate stack_initialized (stack_t s) = - @ (0 < s.size) && \valid (s.data) && \valid_range (s.data, 0, s.size); - @ - @ predicate stack_full (stack_t s) = - @ stack_initialized (s) && (s.used == s.size); - @ - @ predicate stack_empty (stack_t s) = - @ stack_initialized (s) && (s.used == 0); - @ / - -/@ requires \valid (stack); - @ ensures 0 <= \result <= 1; - @ ensures stack_initialized (stack) ==> \result == 1; - @ / - -int -stack_valid (const stack_t stack) -{ - return ((stack->data != NULL) && (stack->size != 0)); -} - -/@ requires \valid (stack); - @ requires \valid (data); - @ requires \valid_range (data, 0, size); - @ requires 0 < size; - @ ensures stack_initialized (stack); - @ ensures stack->used == 0; - @ / - -void -stack_init (stack_t stack, int data, unsigned long size) -{ - stack->data = data; - stack->size = size; - stack->used = 0; -} - -/@ requires \valid (stack); - @ requires stack_initialized (stack); - @ ensures !stack_full (\old (stack)) ==> \old(stack->used) < stack->used; - @ / - -int -stack_push (stack_t stack, int item) -{ - if (stack->used < stack->size) { - stack->used++; - stack->data [stack->used] = item; - return 1; - } else - return 0; -} - -/@ requires \valid (stack); - @ requires stack_initialized (stack); - @ requires \valid (item); / - -int -stack_pop (stack_t stack, int item) -{ - if (stack->used > 0) { - item = stack->data [stack->used]; - stack->used--; - return 1; - } else - return 0; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0463.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0463.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0463.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0463.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -extern int Tab[] ; -/@ behavior default: - ensures (Tab[\at(i,Old)] == \at(v,Old)); - / -extern void writeTab(int i , int v ) ; -/@ behavior default: - ensures (Tab[\at(j,Old)] == \at(x,Old)); - / -void main(int j , int x ) -{ - writeTab(j,x); - return; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0492.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0492.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0492.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0492.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -/ run.config_phoare - OPT: -journal-disable -wp -wp-model Hoare -wp-proof alt-ergo -wp-verbose 2 -/ -/ run.config_pruntime - OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-verbose 2 -wp-proof simplify -/ - - - -//@ logic int Shift_Ptr(int * p, integer i) = p + i ; - -//@ ensures bug:\result == Shift_Ptr(p, i); -int * p_shift (int * p, int i) { - return p + i; -} - - -typedef int Array[12] ; -struct st { Array t ; int a ;} s1 , s2; - -//@ logic Array Mk_Array (Array x) = x ; - -/@ ensures bug1: s1 == { s1 \with .t = Mk_Array(s2.t) } ; - ensures ok1: s1 == { s1 \with .t = s2.t } ; - - ensures bug2: \let v = \old(s1.a) ; - s1 == { s2 \with .a = v } ; - ensures ok2: s1 == { s2 \with .a = \old(s1.a) } ; -/ -void wr_struct (int x) { - int a = s1.a ; - s1 = s2 ; - s1.a = a ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0493.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0493.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0493.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0493.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -//@ ensures \result == p + (\let idx = i ; idx + 0); -int * f(int * p, int i) { - return p + i; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts0657.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts0657.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts0657.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts0657.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -int i; - -//@ requires 1100000000<=i<=1100000001; -int f() -{ - //@ assert 1100000000<=i<=1100000001; - return i; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/bts494.c frama-c-20111001+nitrogen+dfsg/tests/wp/bts494.c --- frama-c-20110201+carbon+dfsg/tests/wp/bts494.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/bts494.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -/* run.config - DONTRUN: test under construction -/ - -//@ ensures \result >= n; -int loop_invariant(int n) { - int i = 0 ; - //@ loop invariant n== \at(n,Pre) && 0 <= i && (0 <=n ==> i <= n); - while (i < n) - i++ ; - return i; -} - - -//@ ensures \result >= n; -int invariant_as_loop_invariant(int n) { - int i = 0 ; - while (i < n) - //@ invariant n== \at(n,Pre) && 0 <= i && i <= n; - i++ ; - return i; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/CallTestPos.c frama-c-20111001+nitrogen+dfsg/tests/wp/CallTestPos.c --- frama-c-20110201+carbon+dfsg/tests/wp/CallTestPos.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/CallTestPos.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -/ - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Proved with all - / - -int z ; -/@ assigns z; - ensures z==x ; -/ -void g(int x,int y); - -void call_void(void) -{ - g(4,5); - - //@ assert z==4; -} - - -int pre; -/@ - requires pre!= 0; - assigns pre ; - ensures \result == post ; -/ -int f (int x, int post) -{ - pre = x ; - return post; - -} - -void call_with_ret(void) -{ - int x ; - x = f(1,2); - //@ assert x == 2; -} - - -int a; - -/@ assigns a; - @ ensures (x>= y ==> \result == x) && (x<y ==> \result ==y); -/ -int f1(int x,int y); - -void call_with_ret_sig(void) -{ - int x = 1; - int y = 2; - x = f1(x,y); - //@assert x==y; - -} - - - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/ConditionalTestPos.c frama-c-20111001+nitrogen+dfsg/tests/wp/ConditionalTestPos.c --- frama-c-20110201+carbon+dfsg/tests/wp/ConditionalTestPos.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/ConditionalTestPos.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -/ - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Proved with all - / - - -//@ ensures \result == 0; -int and_op(void) -{ - return (1==5 && 2 == 2); -} - -//@ ensures \result == 1; -int or_op(void) -{ - return (1==5 || 2 == 2); -} - - -/@ - behavior Case_True : - ensures x==5 ==> \result == 1; - behavior Case_False : - ensures x!=5 ==> \result ==0; -/ -int cond_op(int x) -{ - - return (x==5?1:0); -} - - -int blue; -int green; -int yellow; - -/@ - - behavior Case_2 : - ensures x==-2 ==> \result == blue ; - - behavior Case_3: - ensures x==-1 ==> \result == yellow; - - behavior default : - ensures (x >-1|| x <-2 )==> \result == green; - / - -int other_color(int x) -{ - int r = x+2 ; - if (r==1) return yellow; else - if(r==0) return blue ; else return green; -} - -int main (void) {return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/copy.c frama-c-20111001+nitrogen+dfsg/tests/wp/copy.c --- frama-c-20110201+carbon+dfsg/tests/wp/copy.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/copy.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -/@ - predicate is_valid_int_range(int* p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - requires is_valid_int_range(a, n); - requires is_valid_int_range(b, n); - - assigns b[0..n-1]; - - ensures \forall int i; 0 <= i < n ==> b[i] == a[i]; -/ -void copy(const int a, int n, int* b) -{ - /@ - loop assigns b[0..i-1]; - loop invariant 0 <= i <= n; - loop invariant \forall int k; 0 <= k a[k] == b[k]; - loop variant n-i; - / - for (int i = 0; i < n; ++i) - b[i] = a[i]; -} - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/count.c frama-c-20111001+nitrogen+dfsg/tests/wp/count.c --- frama-c-20110201+carbon+dfsg/tests/wp/count.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/count.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - axiomatic counting_axioms - { - logic integer counting{L}(int* a, integer n, int val) - reads a[0..n-1]; - - axiom counting_empty{L}: - \forall int* a, integer n, int val; n <= 0 ==> - counting(a, n, val) == 0; - - axiom counting_hit{L}: - \forall int* a, integer n, int val; n >= 0 && a[n] == val ==> - counting(a, n+1, val) == counting(a, n, val) + 1; - - axiom counting_miss{L}: - \forall int* a, integer n, int val; n >= 0 && a[n] != val ==> - counting(a, n+1, val) == counting(a, n, val); - } -/ - -/@ - requires is_valid_int_range(a, n); - - assigns \nothing; - - ensures \result == counting(a, n, val); -/ -int count(const int a, int n, int val) -{ - int cnt = 0; - /@ - loop invariant 0 <= i <= n; - loop invariant 0 <= cnt <= i; - loop invariant cnt == counting(a, i, val); - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[i] == val) - cnt++; - - return cnt; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/div.c frama-c-20111001+nitrogen+dfsg/tests/wp/div.c --- frama-c-20110201+carbon+dfsg/tests/wp/div.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/div.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ - -/@ - behavior pos_pos : - assumes (a == 3) && (b == 2); - ensures \result == 1; - - behavior neg_neg : - assumes (a == -3) && (b == -2); - ensures \result == 1; - - behavior neg_pos : - assumes (a == -3) && (b == 2) ; - ensures \result == -1; - - behavior pos_neg : - assumes (a == 3) && (b == -2); - ensures \result == -1; -/ - - -int f (int a,int b) {return (a/b);} - - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/DivEx1.c frama-c-20111001+nitrogen+dfsg/tests/wp/DivEx1.c --- frama-c-20110201+carbon+dfsg/tests/wp/DivEx1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/DivEx1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -/* run.config - DONTRUN: test under construction -/ - -typedef struct {int ch11[10]; int ch12;} T1; -typedef struct {int ch21; T1 ch22;} T2; - -/@ assigns p[0..19].ch21, p[0..19].ch22.ch11[0..9]; - exits never: oracle_ok: \false; - - @ behavior ch21: - ensures ch21: oracle_ok: - \forall int k ; 0 <= k < 20 ==> p[k].ch21 == 0 ; - @ behavior ch22: - ensures ch22_11: oracle_ok: - \forall int k,l ; - 0 <= k < 20 && 0 <= l < 10 - ==> p[k].ch22.ch11[l] == 0 ; - ensures ch22_other: oracle_ok: - \forall int k ; - 0 <= k < 20 - ==> p[k].ch22 == {\old(p[k].ch22) \with .ch11=p[k].ch22.ch11} ; - @/ -void DivEx1 (T2 p) { - int i, j ; - - /@ loop assigns i, j, p[0..i-1].ch21, p[0..i-1].ch22.ch11[0..9]; - loop invariant I0: oracle_ok: 0 <= i <= 20; - - @ for ch21: - loop invariant reset_21: oracle_ok: - \forall int k ; - 0 <= k p[k].ch21 == 0; - @ for ch22: - loop invariant old_part_22: oracle_ok: - \forall int k ; - 0 <= k p[k].ch22 == {\at(p[k].ch22,Pre) \with .ch11=p[k].ch22.ch11} ; - loop invariant new_part_22: oracle_ok: - \forall int k,l ; - 0 <= k p[k].ch22.ch11[l] == 0 ; - - @ loop variant Idecr: oracle_ok: 20 - i ; - / - for (i = 0 ; i < 20 ; i++) { - p[i].ch21 = 0 ; - /@ loop assigns j, p[i].ch22.ch11[0..j-1]; - loop invariant J0: oracle_ok: 0 <= j <= 10; - - @ for ch22: - loop invariant reset_11: oracle_ok: - \forall int k ; 0 <= k < j ==> p[i].ch22.ch11[k] == 0; - - @ loop variant Jdecr: oracle_ok: 10 - j ; - @/ - for (j = 0 ; j < 10 ; j++) - p[i].ch22.ch11[j] = 0 ; - } -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/endian.c frama-c-20111001+nitrogen+dfsg/tests/wp/endian.c --- frama-c-20110201+carbon+dfsg/tests/wp/endian.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/endian.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ - -//@ requires \valid(x); -// void change_endianness(int * x) { -void main (int * x) { -char * p = (char* ) x; -int t; - - /@ assert \valid(p); / - /@ assert \valid(p+1); / - /@ assert \valid(p+2); / - /@ assert \valid(p+3); / - /@ assert ((8+(int )p[1] >= 0) && (8+(int )p[1] < 32)); / - /@ assert ((16+(int )p >= 0) && (16+(int )p < 32)); / - - -t = (p+3) + (p+2)<<8 + (p+1)<<16 + p<<24; -x = t; -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/equal.c frama-c-20111001+nitrogen+dfsg/tests/wp/equal.c --- frama-c-20110201+carbon+dfsg/tests/wp/equal.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/equal.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -/@ - predicate is_valid_int_range(int* p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ - - -/@ - requires is_valid_int_range(a, n); - requires is_valid_int_range(b, n); - - assigns \nothing; - - behavior all_equal: - assumes \forall int i; 0 <= i < n ==> a[i] == b[i]; - ensures \result == 1; - - behavior some_not_equal: - assumes \exists int i; 0 <= i < n && a[i] != b[i]; - ensures \result == 0; - - complete behaviors all_equal, some_not_equal; - disjoint behaviors all_equal, some_not_equal; -/ -int equal(const int a, int n, const int* b) -{ - /@ - loop invariant 0 <= i <= n; - loop invariant \forall int k; 0 <= k a[k] == b[k]; - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[i] != b[i]) - return 0; - - return 1; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/fcts_bhv.c frama-c-20111001+nitrogen+dfsg/tests/wp/fcts_bhv.c --- frama-c-20110201+carbon+dfsg/tests/wp/fcts_bhv.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/fcts_bhv.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -/* - run.config - OPT: -wp-proof none -wp-print -wp-fct f,g - OPT: -wp-proof none -wp-print -wp-fct f,g -wp-bhv B1 - OPT: -wp-proof none -wp-print -wp-bhv B1 - -/ - -//@ predicate P (integer x)= x/2 > 0 ; -//@ predicate P1 (integer x) = x/2 > 0; -//@ predicate P2 (integer x) = x/2 > 0; - -/@ - requires P(1); - assigns \nothing; - behavior B1: - assumes P1(2); - assigns \nothing; - ensures P1(3); - behavior B2: - assumes P2(4); - assigns \nothing; - ensures P2(5); - ensures P(6); - / -void f(void) -{ - int x ; x =1 ; - } - - - -/@ - requires P(7); - assigns \nothing; - behavior B1: - assumes P1(9); - assigns \nothing; - ensures P1(10); - behavior B2: - assumes P2(11); - assigns \nothing; - ensures P2(12); - ensures P(13); - / -void g(void) -{ - int x ; x =1 ; - } - -/@ - requires P(14); - assigns \nothing; - ensures P(15); - / -void h(void) -{ - int x ; x =1 ; - } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/fill.c frama-c-20111001+nitrogen+dfsg/tests/wp/fill.c --- frama-c-20110201+carbon+dfsg/tests/wp/fill.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/fill.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -/@ - predicate is_valid_int_range(int* p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - requires is_valid_int_range(a, n); - - assigns a[0..n-1]; - - ensures \forall int i; 0 <= i < n ==> a[i] == val; -/ -void fill(int a, int n, int val) -{ - /@ - loop invariant 0 <= i <= n; - loop invariant \forall int k; 0 <= k a[k] == val; - loop variant n-i; - / - for (int i = 0; i < n; i++) - a[i] = val; -} - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/find2.c frama-c-20111001+nitrogen+dfsg/tests/wp/find2.c --- frama-c-20110201+carbon+dfsg/tests/wp/find2.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/find2.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - requires is_valid_int_range(a, n); - - assigns \nothing; - - behavior some: - assumes found(a, n, val); - ensures 0 <= \result < n; - ensures a[\result] == val; - ensures !found(a, \result, val); - - behavior none: - assumes !found(a, n, val); - ensures \result == n; - - complete behaviors some, none; - disjoint behaviors some, none; -/ -int find2(const int a, int n, int val) -{ - /@ - loop invariant 0 <= i <= n; - loop invariant !found(a, i, val); - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[i] == val) - return i; - - return n; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/find.c frama-c-20111001+nitrogen+dfsg/tests/wp/find.c --- frama-c-20110201+carbon+dfsg/tests/wp/find.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/find.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ - -/@ - requires is_valid_int_range(a, n); - - assigns \nothing; - - behavior some: - assumes \exists int i; 0 <= i < n && a[i] == val; - ensures 0 <= \result < n; - ensures a[\result] == val; - ensures \forall int i; 0 <= i < \result ==> a[i] != val; - - behavior none: - assumes \forall int i; 0 <= i < n ==> a[i] != val; - ensures \result == n; - - complete behaviors some, none; - disjoint behaviors some, none; -/ -int find(const int a, int n, int val) -{ - /@ - loop invariant 0 <= i <= n; - loop invariant \forall int k; 0 <= k a[k] != val; - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[i] == val) - return i; - - return n; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/find_first_of.c frama-c-20111001+nitrogen+dfsg/tests/wp/find_first_of.c --- frama-c-20110201+carbon+dfsg/tests/wp/find_first_of.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/find_first_of.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ - -int find(const int* a, int n, int val) -{ - /@ - loop assigns i; - loop invariant 0 <= i <= n; - loop invariant \forall int k; 0 <= k a[k] != val; - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[i] == val) - return i; - - return n; -} - -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ -/@ - requires is_valid_int_range(a, m); - requires is_valid_int_range(b, n); - - assigns \nothing; - - behavior found: - assumes found_first_of(a, m, b, n); - ensures 0 <= \result < m; - ensures found(b, n, a[\result]); - ensures !found_first_of(a, \result, b, n); - - behavior not_found: - assumes !found_first_of(a, m, b, n); - ensures \result == m; - - complete behaviors found, not_found; - disjoint behaviors found, not_found; -/ -int find_first_of(const int a, int m, const int* b, int n) -{ - /@ - loop invariant 0 <= i <= m; - loop invariant !found_first_of(a, i, b, n); - loop variant m-i; - / - for(int i = 0; i < m; i++) - if (find(b, n, a[i]) < n) - return i; - - return m; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/huge.c frama-c-20111001+nitrogen+dfsg/tests/wp/huge.c --- frama-c-20110201+carbon+dfsg/tests/wp/huge.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/huge.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -/* run.config - OPT: -wp -wp-huge 9 -wp-print - OPT: -wp -wp-huge 10 -wp-print - / - -int a[5] ; - -//@ensures \result >= 0 ; -int f(void) -{ - int k = 0 ; - int r = 0 ; - if (a[k++]) r++ ; // 0 - if (a[k++]) r++ ; // 1 - if (a[k++]) r++ ; // 2 - if (a[k++]) r++ ; // 3 - if (a[k++]) r++ ; // 4 - return r ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/implicit_prototype.c frama-c-20111001+nitrogen+dfsg/tests/wp/implicit_prototype.c --- frama-c-20110201+carbon+dfsg/tests/wp/implicit_prototype.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/implicit_prototype.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ - - -//@ ensures \result ==a; -int f(int a) -{ return g(3,4,a);} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/IncrDecrTestPos.c frama-c-20111001+nitrogen+dfsg/tests/wp/IncrDecrTestPos.c --- frama-c-20110201+carbon+dfsg/tests/wp/IncrDecrTestPos.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/IncrDecrTestPos.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -/ - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Proved with all - / - -int i,b; - -//@ ensures b == 0; -int res_post_incr(void) -{ - i =0; - b = i++; - return i; -} - -//@ ensures b == 0; -int res_post_decr(void) -{ - i =0; - b = i--; - return i; -} - -//@ ensures b == 1; -int res_pre_incr(void) -{ - i =0; - b = ++i; - return i; -} - -//@ ensures b == 0; -int res_pre_decr(void) -{ - i =1; - b = --i; - return i; -} - -//@ ensures b == \old(i); -int res_post_incr_old(void) -{ - - b = i++; - return i; -} - -//@ ensures b == \old(i); -int res_post_decr_old(void) -{ - b = i--; - return i; -} - -//@ ensures b == i; -int res_pre_incr_old(void) -{ - b = ++i; - return i; -} - -//@ ensures b == i; -int res_pre_decr_old(void) -{ - b = --i; - return i; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/iota.c frama-c-20111001+nitrogen+dfsg/tests/wp/iota.c --- frama-c-20110201+carbon+dfsg/tests/wp/iota.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/iota.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -/@ - predicate is_valid_int_range(int* p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - requires is_valid_int_range(a, n); - requires val + n < ((1<<31)-1); // INT_MAX; - - assigns a[0..n-1]; - - ensures \forall int k; 0 <= k < n ==> a[k] == val + k; -/ -void iota(int a, int n, int val) -{ - /@ - loop assigns a[0..i-1]; - loop invariant 0 <= i <= n; - loop invariant \forall int k; 0 <= k a[k] == val+k; - loop variant n-i; - / - for(int i = 0; i < n; ++i) - a[i] = val + i; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/Loop_bhv.c frama-c-20111001+nitrogen+dfsg/tests/wp/Loop_bhv.c --- frama-c-20110201+carbon+dfsg/tests/wp/Loop_bhv.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/Loop_bhv.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -/@ - assigns \nothing; - ensures \result == n; -/ -int find(int n) -{ - /@ - loop assigns \nothing; - loop invariant 0 <= i <= n; - loop variant n-i; - / - for (int i = 0; i < n; i++) ; - return n; -} - - -/@ - assigns \nothing; - behavior DUMMY : - ensures \result == n; - behavior FOO : - ensures \result == n; -/ -int find_behav(int n) -{ - /@ - loop assigns i; - loop invariant 0 <= i <= n; - loop variant n-i; - / - for (int i = 0; i < n; i++) ; - return n; -} - -int G; -//@ ensures \at(G,Old) == \at(G,Here); -void skip(void) -{ - int i ; i++; -} - - -//@ ensures \result == 0; -int call_find_behav() -{ - int i = find_behav(0); - return i; - -} - - -/@ - assigns G; - ensures G == 5; -/ -int res(int n) -{ - G =5; - /@ - loop assigns \nothing; - loop invariant 0 <= i <= n; - loop variant n-i; - / - for (int i = 0; i < n; i++) ; - return n; -} - -/@ - assigns G; - behavior TEST: - ensures G == 5; -/ -int res_with_behavior(int n) -{ - G =5; - /@ - loop assigns \nothing; - loop invariant 0 <= i <= n; - loop variant n-i; - / - for (int i = 0; i < n; i++) ; - return n; -} - - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/loop_test.c frama-c-20111001+nitrogen+dfsg/tests/wp/loop_test.c --- frama-c-20110201+carbon+dfsg/tests/wp/loop_test.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/loop_test.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ - -//@ requires 0 <= n; // notice that we should be able to relax that. -int loop_var (int n) { - int i, s = 0; - /@ - loop assigns i, s; - loop variant (n - i); - / - for (i = 0; i < n; i++) { - s++; - } - return s; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/Loop_with_call.c frama-c-20111001+nitrogen+dfsg/tests/wp/Loop_with_call.c --- frama-c-20110201+carbon+dfsg/tests/wp/Loop_with_call.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/Loop_with_call.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -/@ - assigns \nothing; - behavior DUMMY : - assumes n == 0 ; - ensures \result == n; - behavior FOO : - ensures \result == n-4+4; -/ -int find_behav(int n) -{ - /@ - loop assigns i; - loop invariant 0 <= i <= n; - loop variant n-i; - / - for (int i = 0; i < n; i++) ; - return n; -} - -//@ ensures \result == 0; - -int call_find_behav(void) -{ - int i = find_behav(0); - return i; - -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/max_element.c frama-c-20111001+nitrogen+dfsg/tests/wp/max_element.c --- frama-c-20110201+carbon+dfsg/tests/wp/max_element.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/max_element.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - requires is_valid_int_range(a, n); - - assigns \nothing; - - behavior empty: - assumes n == 0; - ensures \result == 0; - - behavior not_empty: - assumes 0 < n; - ensures 0 <= \result < n; - ensures \forall int i; 0 <= i < n ==> a[i] <= a[\result]; - ensures \forall int i; 0 <= i < \result ==> a[i] < a[\result]; - - complete behaviors empty, not_empty; - disjoint behaviors empty, not_empty; -/ -int max_element(const int a, int n) -{ - if (n == 0) return 0; - int max = 0; - /@ - loop invariant 0 <= i <= n; - loop invariant 0 <= max < n; - loop invariant \forall int k; 0 <= k a[k] <= a[max]; - loop invariant \forall int k; 0 <= k < max ==> a[k] < a[max]; - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[max] < a[i]) - max = i; - - return max; -} - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/max_seq.c frama-c-20111001+nitrogen+dfsg/tests/wp/max_seq.c --- frama-c-20110201+carbon+dfsg/tests/wp/max_seq.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/max_seq.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - requires is_valid_int_range(a, n); - - assigns \nothing; - - behavior empty: - assumes n == 0; - ensures \result == 0; - - behavior not_empty: - assumes 0 < n; - ensures 0 <= \result < n; - ensures \forall int i; 0 <= i < n ==> a[i] <= a[\result]; - ensures \forall int i; 0 <= i < \result ==> a[i] < a[\result]; - - complete behaviors empty, not_empty; - disjoint behaviors empty, not_empty; -/ -int max_element(const int a, int n) -{ - if (n == 0) return 0; - int max = 0; - /@ - loop assigns i,max; - loop invariant 0 <= i <= n; - loop invariant 0 <= max < n; - loop invariant \forall int k; 0 <= k a[k] <= a[max]; - loop invariant \forall int k; 0 <= k < max ==> a[k] < a[max]; - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[max] < a[i]) - max = i; - - return max; -} - - - -/@ - requires n > 0; - requires \valid(p+ (0..n-1)); - - assigns \nothing; - - ensures \forall int i; 0 <= i <= n-1 ==> \result >= p[i]; - ensures \exists int e; 0 <= e <= n-1 && \result == p[e]; -/ -int max_seq(const int* p, int n) -{ - return p[max_element(p, n)]; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/min_element.c frama-c-20111001+nitrogen+dfsg/tests/wp/min_element.c --- frama-c-20110201+carbon+dfsg/tests/wp/min_element.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/min_element.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - predicate - adjacent_found{Label}(int* a, int n) = - \exists int i; 0 <= i < n-1 && a[i] == a[i+1]; -/ - -/@ - requires is_valid_int_range(a, n); - - assigns \nothing; - - behavior empty: - assumes n == 0; - ensures \result == 0; - - behavior not_empty: - assumes 0 < n; - ensures 0 <= \result < n; - ensures \forall int i; 0 <= i < n ==> a[\result] <= a[i]; - ensures \forall int i; 0 <= i < \result ==> a[\result] < a[i]; -/ -int min_element(int a, int n) -{ - if (0 == n) return n; - - int min = 0; - /@ - loop invariant 0 <= i <= n; - loop invariant 0 <= min < n; - loop invariant \forall int k; 0 <= k a[min] <= a[k]; - loop invariant \forall int k; 0 <= k < min ==> a[min] < a[k]; - loop variant n-i; - / - for (int i = 0; i < n; i++) - if (a[i] < a[min]) - min = i; - - return min; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/minus_of_set.c frama-c-20111001+nitrogen+dfsg/tests/wp/minus_of_set.c --- frama-c-20110201+carbon+dfsg/tests/wp/minus_of_set.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/minus_of_set.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ - - -//@assigns ( \union(p,q)-1); -void f(int p, int * q) -{ (p-1) = 0 ; (q-1)=0;} - -//@assigns (p-(0..2)); -void f2(int p, int * q) -{ (p-1) = 0 ; (q-1)=0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/Mtu.c frama-c-20111001+nitrogen+dfsg/tests/wp/Mtu.c --- frama-c-20110201+carbon+dfsg/tests/wp/Mtu.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/Mtu.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,125 +0,0 @@ -/* run.config - DONTRUN: test under construction -/ - -/ -note: property named "c" is also decomposed into 5 properties - named "case1"..."case5" -/ -typedef struct {int a,b,c ; } TMtu; -/@ - assigns pt->c ; - -behavior oracle_ok: - ensures result: oracle_ok: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - ((x==0)?\result==0 - :((x==p)?\result==e - :\result!=0)) ; - - ensures c: oracle_ok: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - ((x==0)?((e==0)?pt->c==p - :pt->c==0) - :((x==p)?((e!=0)?pt->c==p-1 - :pt->c==p) - :pt->c==x-1)) ; - ensures case1: oracle_ok: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x==0 && e==0 ==> pt->c==p ; - ensures case2: oracle_ok: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x==0 && e!=0 ==> pt->c==0 ; - ensures case3: oracle_ok: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x!=0 && x==p && e!=0 ==> pt->c==p-1 ; - ensures case4: oracle_ok: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x!=0 && x==p && e==0 ==> pt->c==p ; - ensures case5: oracle_ok: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x!=0 && x!=p ==> pt->c==x-1 ; - -behavior oracle_ko: - ensures result: oracle_ko: - \let x = ((c==0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - ((x==0)?\result==0 - :((x==p)?\result==e - :\result!=0)) ; - - ensures c: oracle_ko: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - ((x!=0)?((e==0)?pt->c==p - :pt->c==0) - :((x==p)?((e!=0)?pt->c==p-1 - :pt->c==p) - :pt->c==x-1)) ; - ensures case1: oracle_ko: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x==0 && e==0 ==> pt->c==\old(pt->c) ; - ensures case2: oracle_ko: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x==0 && e!=0 ==> pt->c!=0 ; - ensures case3: oracle_ko: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x!=0 && x==p && e!=0 ==> pt->c==p ; - ensures case4: oracle_ko: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x!=0 && x==p && e==0 ==> pt->c==p-1 ; - ensures case5: oracle_ko: - \let x = ((c!=0)?((e!=0)?(p-m) - :0) - :\old(pt->c)) ; - x!=0 && x!=p ==> pt->c==x ; -/ -int Mtu( TMtu pt, int e, int c, int p, int m ) { - int r; - - if (c) - if (e) - pt->c = p - m; - else - pt->c = 0; - - if (!pt->c) { - r = 0; - if ( !e ) - pt->c = p; - } - else if (pt->c == p) { - r = e; - if (e) - pt->c = pt->c - 1; - } - else { - r = 1; - pt->c = pt->c - 1; - } - return r; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/NullCmpTestPos.c frama-c-20111001+nitrogen+dfsg/tests/wp/NullCmpTestPos.c --- frama-c-20110201+carbon+dfsg/tests/wp/NullCmpTestPos.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/NullCmpTestPos.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ - - -int p; -/@ requires \valid (p); - ensures \result == 0; -/ -int main(void) -{ - - return (p == (char ) 0); -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/numeric_addr.c frama-c-20111001+nitrogen+dfsg/tests/wp/numeric_addr.c --- frama-c-20110201+carbon+dfsg/tests/wp/numeric_addr.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/numeric_addr.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -/* run.config_pruntime - OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-proof z3 -wp-print -wp-verbose 2 -/ - - -/@ requires (no_rte: \valid(Valeur)); - requires (no_rte: \valid((unsigned int )0x12345678)); - requires (no_rte: \separated(Valeur, (unsigned int )0x12345678)); - ensures Valeur == \old((unsigned int )0x12345678); -/ -void LireStatusCpu(unsigned int Valeur ) { - /@ assert (rte: \valid(Valeur)); / - /@ assert (rte: \valid((unsigned int )0x12345678)); / - Valeur = ((unsigned int )0x12345678); - return; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/pointer_arith.c frama-c-20111001+nitrogen+dfsg/tests/wp/pointer_arith.c --- frama-c-20110201+carbon+dfsg/tests/wp/pointer_arith.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/pointer_arith.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ - - - - -int T[10]; - -int x; - -/@ behavior no_alias : - assumes i != j; - ensures \result == \old(T[j]); - behavior with_alias : - assumes i == j; - ensures \result == 1; -/ -int tab_read_write (int i, int j) { - T[i] = 1; - return T[j]; -} - -/@ requires \valid (p) && \valid (q) && p != q; - ensures \result == \old(q) && p == 3; / -int no_alias (int p, int * q) { - p = 3; - return q; -} - -/@ - requires \valid (p) ; - ensures \result == 3 ; -/ -int wptr (int p) { - - p = 3; - x = p; - return p; - -} - -void cmp_addr_loc () { - int i, j; - //@ assert &i != &j; - if (&i < &j) return; - //@ assert &i >= &j; - if (&i - &j > 0) return; - //@ assert \false; -} - -//@ ensures i == j ==> \result == 0; -int cmp_ptr (int i, int j) { - int * pi = T+i; - int * pj = T+j; - if (pi < pj) return -1; - if (pi - pj > 0) return 1; - return 0; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/prop_n.c frama-c-20111001+nitrogen+dfsg/tests/wp/prop_n.c --- frama-c-20110201+carbon+dfsg/tests/wp/prop_n.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/prop_n.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -/* - run.config - OPT: -wp-proof none -wp-print -wp-prop A - OPT: -wp-proof none -wp-print -wp-prop A,B - - / - - - - -//@ predicate P(integer i) = i >= 0 ; - -int y; - -/@ - requires P(x); - assigns \nothing; - ensures A:P(y); - ensures B:P(z); - ensures P(y+z); -/ - int f(int x, int z) - { return z; } - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/ptr_incr.c frama-c-20111001+nitrogen+dfsg/tests/wp/ptr_incr.c --- frama-c-20110201+carbon+dfsg/tests/wp/ptr_incr.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/ptr_incr.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -# pragma SeparationPolicy(none) -/@ - requires \valid(p); - requires \valid(q); - ensures p==\old(p)+1; - ensures q==\old(q)+1; - / -void ptr_incr(int p,int q) -{ - p+=1; q+=1; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/range_test1.c frama-c-20111001+nitrogen+dfsg/tests/wp/range_test1.c --- frama-c-20110201+carbon+dfsg/tests/wp/range_test1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/range_test1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -/ run.config_phoare - OPT: -journal-disable -wp -wp-model Hoare -wp-proof alt-ergo -wp-verbose 2 -/ - -int T[10]; - -/@ assigns T[0..4]; - ensures T[5] == \old(T[5]); -/ -void assign_T (void) { - int i; - /@ loop assigns i, T[0..4]; - @ loop invariant 0 <= i; - / - for (i = 0; i < 5; i++) { - T[i] ++; - } -} -// -struct Ts { int a; int t[10]; }; -struct Ts S; - -/@ ensures (T[5] == \old(T[5])); - ensures (S.a == \old(S.a)); -/ -void assign_S (void) { - int i; - //@ loop assigns i, S.t[..]; - for (i = 0; i < 5; i++) { - S.t[i] = T[i]; - } -} -//~~ -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/remove_copy.c frama-c-20111001+nitrogen+dfsg/tests/wp/remove_copy.c --- frama-c-20110201+carbon+dfsg/tests/wp/remove_copy.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/remove_copy.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -/ run.config - DONTRUN: invalid ACSL annotations (unbound function counting) -/ - -/@ - predicate is_valid_int_range(int* p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - requires is_valid_int_range(a, n); - requires is_valid_int_range(b, n); - - assigns b[0 .. n-1]; - - ensures \forall int k; \result <= k < n ==> b[k] == \old(b[k]); - ensures \forall int k; 0 <= k < \result ==> b[k] != val; - ensures \forall int x; x != val ==> - counting(a, n, x) == counting(b, \result, x); - ensures \result == n - counting(a, n, val); - ensures 0 <= \result <= n; -/ -int remove_copy(const int a, int n, int* b, int val) -{ - int j = 0; - /@ - loop assigns b[0..j-1]; - - loop invariant 0 <= j <= i <= n; - loop invariant \forall int k; j <= k < n ==> - b[k] == \at(b[k],Pre); - loop invariant \forall int k; 0 <= k < j ==> b[k] != val; - loop invariant \forall int x; x != val ==> - counting(a,i,x) == counting(b,j,x); - loop invariant j == i - counting(a,i,val); - - loop variant n-i; - / - for (int i = 0; i < n; ++i) - if (a[i] != val) - b[j++] = a[i]; - return j; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/replace_copy.c frama-c-20111001+nitrogen+dfsg/tests/wp/replace_copy.c --- frama-c-20110201+carbon+dfsg/tests/wp/replace_copy.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/replace_copy.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -/@ - predicate is_valid_int_range(int p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); - -/ -/@ - predicate - found{A}(int* a, int n, int val) = - \exists int i; 0 <= i < n && a[i] == val; -/ -/@ - predicate - found_first_of{A}(int* a, int m, int* b, int n) = - \exists int i; 0 <= i < m && found{A}(b, n, \at(a[i],A)); -/ - -/@ - requires is_valid_int_range(a, n); - requires is_valid_int_range(b, n); - - assigns b[0 .. n-1]; - - ensures \forall int j; 0 <= j < n ==> - a[j] == old_val && b[j] == new_val || - a[j] != old_val && b[j] == a[j]; - ensures \result == n; -/ -int replace_copy(const int a, int n, int* b, int old_val, int - new_val) -{ - /@ - loop assigns b[0..i-1]; - loop invariant 0 <= i <= n; - loop invariant \forall int j; 0 <= j - a[j] == old_val && b[j] == new_val || - a[j] != old_val && b[j] == a[j]; - loop variant n-i; - / - for (int i = 0; i < n; ++i) - b[i] = (a[i] == old_val ? new_val : a[i]); - - return n; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/ResultLogicStructArray.c frama-c-20111001+nitrogen+dfsg/tests/wp/ResultLogicStructArray.c --- frama-c-20110201+carbon+dfsg/tests/wp/ResultLogicStructArray.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/ResultLogicStructArray.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -/* - kind : Positive - model name : Store ; bhv : Not Yet Translated - model name : Hoare ; bhv : Out of Scope - / - -int x,y; -struct S { int a; }; - -//@ assigns (\result.a); -struct S result_field (void) -{ - struct S s; - s.a = &x; - x=4; - return s; -} - -int main (void) { return 0;} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/RstarS.c frama-c-20111001+nitrogen+dfsg/tests/wp/RstarS.c --- frama-c-20110201+carbon+dfsg/tests/wp/RstarS.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/RstarS.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -/ run.config - DONTRUN: test under construction -/ - -/ note: properties named "oracle_ko" are not true ! -/ -/@ requires \valid(RstarSQ); - assigns RstarSQ ; - ensures \result == RstarSQ; - - behavior b1: - assumes R==0 && S!=0 ; - ensures oracle_ok: RstarSQ!=0; - ensures oracle_ko: RstarSQ==0; - - behavior b2: - assumes R==0 && S==0 ; - ensures oracle_ok: RstarSQ==\old(RstarSQ); - ensures oracle_ko: RstarSQ!=\old(RstarSQ); - - behavior b3: - assumes R!=0 ; - ensures oracle_ok: RstarSQ==0; - ensures oracle_ko: RstarSQ!=0; - - complete behaviors ; - disjoint behaviors ; -/ -int RstarS(int RstarSQ, int R, int S) { - if (!R && S) - RstarSQ=1; - else if (R) - RstarSQ=0; - return RstarSQ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/SimpleExpTestNeg.c frama-c-20111001+nitrogen+dfsg/tests/wp/SimpleExpTestNeg.c --- frama-c-20110201+carbon+dfsg/tests/wp/SimpleExpTestNeg.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/SimpleExpTestNeg.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -//@ ensures \result > 4; -int res_lt(void) -{ - return 4; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/SimpleExpTestPos.c frama-c-20111001+nitrogen+dfsg/tests/wp/SimpleExpTestPos.c --- frama-c-20110201+carbon+dfsg/tests/wp/SimpleExpTestPos.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/SimpleExpTestPos.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -/ - kind : Positive - model name : Store ; bhv : Provable - model name : Hoare ; bhv : Proved with alt-ergo - / - -//@ ensures \result == 4; -int res_int_cst(void) -{ - return 4; -} - -//@ ensures \result >= 4; -int res_int_cst_lt() -{ - return 4; -} - - - -//@ ensures \result == -4; -int res_unop_neg(void) -{ - int i = 4; return -i; -} - - -//@ ensures \result == 4; -int res_unop_pos(void) -{ - int i = 4; return +i; -} - -/ -//@ensures \result == 1 && z == 1; -int res_unop_not(void) -{ int z; - z = !0; - return !4 ; } -/ - -//@ ensures \result == 4; -int res_additive_operator(void) -{ - return (4+5-5); -} - - -//@ ensures \result == 4; -int res_multiplicative_operator(void) -{ - return (45/5); -} - -//@ ensures \result != 0; -int res_equality(void) -{ - - int c,d,e; - c=5 ; - e=3 ; - d= (c+e); - return (d==8); -} - - -//@ ensures \result == 1; -int res_relation(void) -{ - - int c,d,e; - c=5 ; - e=3 ; - d= (c+e); - return (d>=8); -} - - - - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/struct.c frama-c-20111001+nitrogen+dfsg/tests/wp/struct.c --- frama-c-20110201+carbon+dfsg/tests/wp/struct.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/struct.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -/* run.config -CMD: FRAMAC_SHARE=./share ./bin/toplevel.opt -OPT: -no-lib-entry -wp -wp-model Store -wp-proof none -wp-print -wp-verbose 2 -wp-assigns effect -OPT: -no-lib-entry -wp -wp-model Hoare -wp-proof none -wp-print -wp-verbose 2 -OPT: -no-lib-entry -wp -wp-model UnsafeCaveat -wp-proof none -wp-print -wp-verbose 2 -OPT: -no-lib-entry -wp -wp-model Runtime -wp-proof none -wp-print -wp-verbose 2 -wp-assigns effect -FILTER: tests/wp/filter_wp_res -/ - -/ run.config_why - OPT: -wp -wp-assigns effect -wp-timeout 1 -wp-proof alt-ergo -wp-par 1 - / - -struct S { int i; }; - -/@ ensures p1: oracle_ok: \forall struct S v ; (v.i == 0 ==> \result == v); - ensures p2: oracle_ok: \forall struct S v ; \result == { v \with .i = (int)0 } ; - assigns \nothing ; - @ / -struct S f(void) { - struct S s = { 0 }; - return s; -} - -struct S2 { int a; struct S s; int t[2]; struct S ts[5]; } Gs, Ps; -struct S Gs1, Gs2; -/@ensures p1: oracle_ok: Gs.a == 1 ; - ensures p2: oracle_ok: Gs.s.i == 1 ; - ensures p3: oracle_ok: Gs.t[0] == 3 && Gs.t[1] == 3 ; - ensures p4: oracle_ok: Gs.ts[3].i == 4; - - ensures p5: oracle_ok: Gs1 == {\old(Gs1) \with .i = (int) 1 } ; - ensures p6: oracle_ok: Gs.s == {\old(Gs.s) \with .i = (int) 1 } ; - - // assigns Gs.a, Gs.s.i, Gs.t[0], Gs.t[1], Gs.ts[3].i; <----- FAUX - assigns Gs.a, Gs.s.i, Gs.t[0], Gs.t[1], Gs.ts[3].i, Gs1.i, Gs2.i ; - @ / -void f2 () { - Gs.a = 1; - Gs.s.i = Gs.a; - Gs.t[0] = 3; - Gs.t[Gs.a] = 3; - Gs.ts[3].i = Gs.t[0] + 1; - Gs1.i = 1; - Gs2.i = 1; - //@ assert a1: SI_PAS_DE_PADDING: oracle_ok: Gs1==Gs2; // <--- should be prouvable -} - -union U { int a; int b; char c; } Gu; - -void fu () { - Gu.a = 0; - //@ assert a1: oracle_ok: Gu.a == 0; - Gu.b = 1; - //@ assert a2: oracle_ok: Gu.b == 1; -} -union U Ggu; -void fu2 () { - Gu.a = 0; - Gu.b = 1; - //@ assert a1: oracle_ok: Gu.a == 1; - // this one is ok but need M3 (or maybe M2 ???) - //@ assert a2: oracle_ko: Gu.a == 0; - // the last one is false ! - Gu.c = 2; - Ggu.a=0; - Ggu.b=1; - Ggu.c = 2; - //@ assert a3: SI_PAS_PADDING: oracle_ok: Ggu==Gu; // <--- should be prouvable -} -int main (void) { return 0 ; } - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/struct_store.c frama-c-20111001+nitrogen+dfsg/tests/wp/struct_store.c --- frama-c-20110201+carbon+dfsg/tests/wp/struct_store.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/struct_store.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -struct R {int a; int b;}; - -struct S {struct R f;} ; - - -struct R r; -struct S s; - -//@ ensures oracle_ok:s == { \old(s) \with .f = r}; -int f (void) -{ s.f = r ; - return s.f.a; -} - -//@ ensures oracle_ok:s == { \old(s) \with .f = r1}; -int f2 (struct R r1) -{ - r = r1; - s.f = r ; - return 1; -} - -struct R r3; - -//@ ensures oracle_ko: s == { \old(s) \with .f = r3}; -int f3_false (struct R r1) -{ - r = r1; - s.f = r ; - return 1; -} - -/@ ensures oracle_ok: s == { \old(s) \with .f = r1}; - @ ensures oracle_ok: s == { s1 \with .f = r1}; - / -int f4_true (struct S s1, struct R r1) -{ - s1.f = r1; - s =s1 ; - s1.f = r; - return 0; -} - -//@ ensures oracle_ko: s == { \old(s) \with .f = r}; -int f4_false (struct S s1, struct R r1) -{ - s1.f = r1; - s =s1 ; - s1.f = r; - return 0; -} - -//@ ensures oracle_ok: \result == r1; -struct R struct_copy (struct R r1) -{ - struct R tmp; - tmp.a = r1.a; - tmp.b = r1.b; - return tmp; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/StructTestPos.c frama-c-20111001+nitrogen+dfsg/tests/wp/StructTestPos.c --- frama-c-20110201+carbon+dfsg/tests/wp/StructTestPos.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/StructTestPos.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -struct s {int a;}; - -//@ ensures \result == 4; -int field_eq_load(void) -{ - struct s s1,s2; - s1.a =4; - s2 = s1; - return s2.a; -} - -struct s s1,s2; -//@ ensures s2 == s1; -void equal_record_test(void) -{ - s2 =s1 ; - -} - -struct Ts {struct s s1; int t[10];} ; - -struct Ts ts1, ts2; -//@ ensures \result == ts1.t[0] ; -int equal_with_array_field (void) -{ - ts1=ts2; - return ts2.t[0]; -} - -struct S {int a;}; - -struct S s; - - -/@ requires s.a == 5; - assigns s.a; - ensures \result == {s \with .a = (int)4 }; -/ -struct S ret_struct(void) -{ - s.a = 4; - return s; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/swap.c frama-c-20111001+nitrogen+dfsg/tests/wp/swap.c --- frama-c-20110201+carbon+dfsg/tests/wp/swap.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/swap.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -# pragma SeparationPolicy(none) - -/@ - requires \valid(p); - requires \valid(q); - - - assigns p; - assigns q; - - ensures p == \old(q); - ensures q == \old(p); -/ -void swap(int p, int* q) -{ - int const save = p; - p = q; - q = save; -} - -int main () { - int p[2] = { 0,1}; - int q = (int )((char)q+1); - swap(p,q); -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/swap_range.c frama-c-20111001+nitrogen+dfsg/tests/wp/swap_range.c --- frama-c-20110201+carbon+dfsg/tests/wp/swap_range.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/swap_range.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -/@ - predicate is_valid_int_range(int* p, int n) = - (0 <= n) && \valid_range(p,0,n-1); - - lemma foo: \forall int* p,n; is_valid_int_range(p,n) <==> \valid_range(p,0,n-1); -/ - -/@ - requires \valid(p); - requires \valid(q); - requires \separated(p,q); - - assigns p; - assigns q; - - ensures p == \old(q); - ensures q == \old(p); -/ -void swap(int p, int* q) -{ - int const save = p; - p++;p--; - p = q; - q = save; -} - - - -/@ - requires is_valid_int_range(a, n); - requires is_valid_int_range(b, n); - //requires \separated(a, b); - - assigns a[0..n-1]; - assigns b[0..n-1]; - - ensures \forall int k; 0 <= k < n ==> a[k] == \old(b[k]); - ensures \forall int k; 0 <= k < n ==> b[k] == \old(a[k]); -/ -void swap_ranges(int* a, int n, int* b) -{ - /@ - loop assigns a[0..i-1]; - loop assigns b[0..i-1]; - - loop invariant 0 <= i <= n; - loop invariant \forall int k; 0 <= k - a[k] == \at(b[k],Pre); - loop invariant \forall int k; 0 <= k - b[k] == \at(a[k],Pre); - - loop variant n-i; - / - for (int i = 0; i < n; i++) - swap(&a[i], &b[i]); -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/swap_sep.c frama-c-20111001+nitrogen+dfsg/tests/wp/swap_sep.c --- frama-c-20110201+carbon+dfsg/tests/wp/swap_sep.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/swap_sep.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ - - -/@ - requires \valid(p); - requires \valid(q); - requires \separated(p,q); - - assigns p; - assigns q; - - ensures p == \old(q); - ensures q == \old(p); -/ -void swap(int* p, int* q) -{ - int const save = p; - p++;p--; - p = q; - q = save; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/TCA_Automaton_pp.c frama-c-20111001+nitrogen+dfsg/tests/wp/TCA_Automaton_pp.c --- frama-c-20110201+carbon+dfsg/tests/wp/TCA_Automaton_pp.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/TCA_Automaton_pp.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1348 +0,0 @@ -# 1 "TCA_Automaton.c" -# 1 "<interne>" -# 1 "<ligne de commande>" -# 1 "TCA_Automaton.c" -/******************************************************************** -* MACHINE TERMINALE TCA_Automaton -******************************************************************** -* Descriptif : -* TCA_Automaton is a terminal machine and is in charge of managing the states -* depending on the input events generated by TCR_FileReader or TCW_FileWriter. -* and also emitting the events based on the state transition. -* -/ -/ -CONTEXTE -/ - -# 1 "TCA_Automaton.i" 1 -/ - MACHINE TERMINALE TCA_Automaton -******************************************************************** -* Mnemonique : -* TCA -* -* Definition : -* TCA_Automaton is a terminal machine and is in charge of managing the states -* depending on the input events generated by TCR_FileReader or TCW_FileWriter. -* and also emitting the events based on the state transition. -* -* Particularites : -* AUCUNE -/ -# 1 "/projets/u3cat/ETUDES/ASF/DLAC_V1_3/DLAC/src/frama-c/inc/STANDARD_C.h" 1 - - - - -/ - MACHINE TERMINALE STANDARD_C -******************************************************************** -* Mnemonique : -* UST -* -* Definition : -* STANDARD_C abstract machine is makes to replace services of standard -* C library, to allow -* to perform all covering tests on embedded code -* It also define: -* - all basic types used by subsets of CMS-ACD function -* - PORTABLES services, independant on the storing mode of bytes in memory, -* -* performed by the CPU -* - a CRC computation service, used by several subsets -* - a formatting service, allowing to switch from a LittelEndian or BigEndian -* -* platform (PACK) to AFDX (BigEndian) world, -* - a unformattind service, allowing to switch from AFDS world (BigEndian) -* to -* LittelEndian or BigEndian platform (UNPACK). -* -* A data coded on serveral bytes respecting the Big-Edian convention means -* that -* le most significant byte of the data is located at the lowest adress. -* A data coded on serveral bytes respecting the Little-Edian convention -* means -* that le less significant byte of the data is located at the lowest adress. -* -* For example, 32 bytes data which value is 0xDEADBEEF will be represented -* in -* memory as follow: -* Big-endian memory Little-endian memory -* storing convention storing convention -* Address Value Address Value -* ------- ----- ------- ----- -* @Base DE @Base EF -* @Base+1 AD @Base+1 BE -* @Base+2 BE @Base+2 AD -* @Base+3 EF @Base+3 DE -* -* Of course the principle is the same for a data coded on 16 binary digits -* (2 bytes), -* or 64 binary digits (8 bytes). -* Remark: The order of binary digit of each byte remains unchanged. -* -* For CMS-ACD needs, only services PACK/UNPACK for 16, 32 et 64 binary -* digits data are -* implemented. -* -* Particularites : -* AUCUNE -/ - -/ -TYPES, RESSOURCES, CONSTANTES EXPORTES -*********************************************************************/ - -typedef enum {FALSE=0, TRUE=1} BOOLEAN; - -typedef char CHAR; - -typedef unsigned char BYTE; - -typedef BYTE * TP_BYTE; - -typedef TP_BYTE const TP_BYTE_CST; - -typedef char* STRING; - -typedef STRING const STRING_CST; - -typedef float FLOAT32; - -typedef FLOAT32 * TP_FLOAT32; - -typedef double FLOAT64; - -typedef FLOAT64 * TP_FLOAT64; - -typedef signed char INT8; - -typedef INT8 * TP_INT8; - -typedef signed short INT16; - -typedef INT16 * TP_INT16; - -typedef signed int INT32; - -typedef INT32 * TP_INT32; - -typedef unsigned char UINT8; - -typedef unsigned char * TP_UINT8; - -typedef unsigned short int UINT16; - -typedef UINT16 * TP_UINT16; - -typedef unsigned int UINT32; - -typedef UINT32 * TP_UINT32; - -typedef void VOID; - -typedef void * TP_VOID; - -typedef void * const TP_VOID_CST; - -typedef unsigned short WORD16; - -typedef WORD16 * TP_WORD16; - -typedef unsigned int WORD32; - -typedef WORD32 * TP_WORD32; - -typedef unsigned long long WORD64; - -typedef WORD64 * TP_WORD64; - -typedef unsigned long long INT64; - -typedef char STRING_ARRAY; -# 164 "/projets/u3cat/ETUDES/ASF/DLAC_V1_3/DLAC/src/frama-c/inc/STANDARD_C.h" -/****************************************************************** -SERVICES EXPORTES -/ - - - -/ -* SERVICE UST_Me_PackBigEndian16 -******************************************************************** -* -* Fonction : -* Function : -* This macro convert a data of any type coded on 16 binary digits (Value16digits) -* into a table of 2 bytes (ValBigEndian), coded on BigEndian convention. -* This macro is independant of the platform architecture (on LittleEndian -* or BigEndian -* convention) and must be used when ever the user shall export a data coded -* on 16 binary -* digits, directlly or indirectly. -* -* Input parameters : -* - Value16digits : variable to be converted (its type doesn't matter, -* its shall -* be coded 16 binary digits) -* -* Output parameters : -* - ValBigEndian : table of 2 bytes, allocated by the user, containing -* the variable -* after conversion. -* -/ - - - -/ - SERVICE UST_Me_PackBigEndian32 -******************************************************************** -* -* Fonction : -* Function : -* This macro convert a data of any type of 32 binary digits (Value32digits) -* in a table of 4 bytes (ValBigEndian) on BigEndian convention -* This macro is not dependant on platform architecture (LittleEndian or -* BigEndian convention), -* and must be used when ever the user shall export a data of 32 binary -* digits, -* directly or indirectly. -* -* Input parameters: -* - Value32digits : variable to be convert (the type of the variable -* doesn't matter, the variable -* just needs to be coded on 32 binary digits) -* -* Ouput parameters: -* - ValBigEndian : table of 4 bytes, allocated by the user, containing -* -* the variable after conversion. -* -/ - - - -/ - SERVICE UST_Me_PackBigEndian64 -******************************************************************** -* -* Fonction : -* Function : -* This macro convert a data of any type coded on 64 binary digits (Value64digits) -* into a table of 8 bytes (ValBigEndian) on BigEndian convention. -* This macro is not dependent on the platform architecture (on LittleEndian -* or BigEndian convention) and must be used -* when ever the user shall export a data on 64 binary digits, directly -* ou indirectly. -* -* Input parameters : -* - Value64digits : variable to be converted (its type doesn't matter, -* it just -* need to be coded on 64 binary digits) -* -* Ouput parameters : -* - ValBigEndian : table of 8 octets, allocated by the user, containing -* the variable after conversion. -* -/ - - - -/ - SERVICE UST_Me_UnpackBigEndian16 -******************************************************************** -* -* Fonction : -* Function : -* This macro converts a table of 2 bytes (ValBigEndian) on BigEndian -* convention into a data of any type on 16 binary digits -* (Value16digits). -* This macro does not depend on the platform architecture -* (on LittleEndian or BigEndian convention)and must be used when ever -* the user shall interpret a data coded on 16 bits -* -* Input parameters : -* - ValBigEndian : table of 2 bytes, containing the value to convert. -* -* Ouput parameters : -* - Value16digits : converted result (whatever the type is) -* -/ - - - -/ - SERVICE UST_Me_UnpackBigEndian32 -******************************************************************** -* -* Fonction : -* Function : -* This macro converts a table of 4 bytes (ValBigEndian) on BigEndian -* convention into a data of any type on 32 binary digits -* (Value32digits). -* This macro does not depend on the platform architecture -* (on LittleEndian or BigEndian convention)and must be used when ever -* the user shall interpret a data coded on 32 bits -* -* Input parameters : -* - ValBigEndian : table of 4 bytes, containing the value to convert. -* -* Ouput parameters : -* - Value32digits : converted result (whatever the type is) -* -/ - - - -/ - SERVICE UST_Me_UnpackBigEndian64 -******************************************************************** -* -* Fonction : -* Function : -* This macro converts a table of 8 bytes (ValBigEndian) on BigEndian -* convention into a data of any type on 64 binary digits -* (Value64digits). -* This macro does not depend on the platform architecture -* (on LittleEndian or BigEndian convention)and must be used when ever -* the user shall interpret a data coded on 64 bits -* -* Input parameters : -* - ValBigEndian : table of 8 bytes, containing the value to convert. -* -* Ouput parameters : -* - Value64digits : converted result (whatever the type is) -* -/ - - - -/ - SERVICE UST_Se_MemCmp -******************************************************************** -* -* Fonction : -* Function : -* This service compares byte by byte, 2 blocks of NbByt bytes stored -* respectively in addresses BlocMem1 and BlocMem2. The contain of each -* byte -* is interpreted as a natural integer belonging to the range 0..255. -* -* Input parameters : -* - BlocMem1 : memory address of one of blocks to be compared -* ; -* - BlocMem2 : memory address of the other block ; -* - NbByt : number of bytes on wich the comparaison shall be done. -* -* Ouput parameters : -* -* Returned value : -* The function returns a signed integer which report the comparaison -* result: -* 0 if block1 = block2 or if NbByt is null ; -* >0 si block1 > block2 ; -* <0 si block1 < block2. -* -*********************************************************************/ -extern INT32 UST_Se_MemCmp - (const void * const /* in / string1, - const void const /* in / string2, - const INT32 / in */ size); - - -/******************************************************************** -* SERVICE UST_Se_MemCpy -******************************************************************** -* -* Fonction : -* Function : -* This service copies to memory address BlocMem1 (destination) a block -* of NbByt -* consecutive bytes stored at memory address BlocMem2 (source). -* If NbByt is null, BlocMem1 remains unchanged. -* -* Input parameters : -* - dest : address of memory block to be crushed; -* - src : address of memory block to be copied ; -* - size : number of bytes to be copied. -* -* Ouput parameters : -* -*********************************************************************/ -//extern void UST_Se_MemCpy -// (VOID * const /* out / dest, -// const void const /* in / src, -// const INT32 / in */ size); - - - -/******************************************************************** -* SERVICE UST_Se_MemMove -******************************************************************** -* -* Fonction : -* Function : -* This function copies NbOctets bytes of the area ZoneMem2 (source) in -* area ZoneMem1 -* (destination) while managing any possible overlap between the two memory -* areas. -* If NbBytes is nul, ZoneMem1 remains unchanged. -* -* Input parameters : -* - ZoneMem1 : address of the memory area which will be crushed ; -* - ZoneMem2 : address of the memory area which will be copied ; -* - NbBytes : number of bytes to be copied. -* -* Ouput parameters : -* -*********************************************************************/ -//extern void UST_Se_MemMove -// (VOID * const /* out / dest, -// const void const /* in / src, -// const INT32 / in */ size); - - - -/******************************************************************** -* SERVICE UST_Se_MemSet -******************************************************************** -* -* Fonction : -* Function : -* This service initialises a memory block of NbByt consecutive bytes located -* -* a the address BlocMem with the value ValByt. -* If NbByt is null, BlocMem remains uninitialised. -* -* Input parameters : -* - BlocMem : address of the memory area to be initialised ; -* - ValByt : value to initialise all bytes of the memory area with; -* - NbByt : number of bytes to be initialised. -* -* Ouput parameters : -* -*********************************************************************/ -//extern void UST_Se_MemSet -// (VOID * const /* out / s, -// const INT32 / in / c, -// const INT32 / in */ size); - - - -/******************************************************************** -* SERVICE UST_Se_StrCat -******************************************************************** -* -* Fonction : -* Function : -* This service concatenates a copy of string String2 (source) -* with string String1 (destination), in the order "String1String2", -* and add the character "enf of string" at the end of the result . -* The first character of String2 crushs the character end of string String1. -* The result of the concatenation is stored in String1. -* -* Input parameters : -* - String1 : address of the destination string ; -* - String2 : address of the source string. -* -* Ouput parameters : -* -* Returned code : -* -*********************************************************************/ -extern void UST_Se_StrCat - (CHAR * const /* out / dest, - const char const /* in */ src); - - -/******************************************************************** -* SERVICE UST_Se_StrCmp -******************************************************************** -* -* Fonction : -* Function : -* This service compares character by character the strings String1 -* and String2 by comparing their ASCII value. -* -* The comparison stops if the character "end of string" is found in one -* of -* the two strings. -* -* Input parameters : -* - String1 : address of one strings to be compared ; -* - String2 : address of the other string. -* -* Ouput parameters : -* -* Returned value : -* The function returns a signed integer which reports the result of the -* -* comparison : -* 0 if String1 = String2 -* >0 if String1 > String2 -* <0 if String1 < String2. -* -*********************************************************************/ -extern INT32 UST_Se_StrCmp - (const char * const /* in / string1, - const char const /* in */ string2); - - -/******************************************************************** -* SERVICE UST_Se_StrCpy -******************************************************************** -* -* Fonction : -* Function : -* This service copies the string String2 (source) int the string String1 -* (destination), until and including the characer "end of string". -* The copy stops as soon as the character "end of string" of String2(source) -* -* is encountered. -* The result od the copy is strored in String1. -* -* Input parameters : -* - String1 : address of the string to be crushed ; -* - String2 : address of the string to be copied. -* -* Ouput parameters : -* -* Returned code : -* -*********************************************************************/ - -extern void UST_Se_BisStrCpy - (CHAR * const /* out / dest, - const char const /* in */ src); - - -/******************************************************************** -* SERVICE UST_Se_StrLen -******************************************************************** -* -* Fonction : -* Function : -* This service returns the number of characters hold in the string "String", -* excluding the character "end of string". -* -* Input parameters : -* - String : address of the string, which the size is to be measured. -* -* Ouput parameters : -* -* Returned value : -* - the length of the string, expressed in number of bytes. -* -*********************************************************************/ -extern INT32 UST_Se_StrLen - (const char * const /* in */ string); - - -/******************************************************************** -* SERVICE UST_Se_StrnCat -******************************************************************** -* -* Fonction : -* Function : -* This service concatenates at most the NbChar firsts characters of String2 -* (source) -* after the string String1 (destination) and add the character "end of -* string" at the -* end of the result . -* The first character of String2 crushes the character "enf of string" -* of String1. -* The result of the concatenation is stored in String1. -* If NbChar is null, String remains unchanged. -* -* Input parameters : -* - String1 : address of the destination string ; -* - String2 : address of the source string ; -* - NbChar : number of characters of String2 to be concatenate after -* String1. -* -* Ouput parameters : -* -* Returned code : -* -*********************************************************************/ -extern void UST_Se_StrnCat - (CHAR * const /* out / dest, - const char const /* in / src, - const INT32 / in */ size); - - -/******************************************************************** -* SERVICE UST_Se_StrnCmp -******************************************************************** -* -* Fonction : -* Function : -* This service compares character by character at most the NbChar first -* characters of strings String1 and String2 by comparing their ASCII value. -* The comparison stops if the character "end of string" is encountered -* -* in one of the two strings. -* If NbChar is null, the service returns 0. -* -* Input parameters : -* - String1 : address of one the two strings to be compared ; -* - String2 : address of the other string ; -* - NbChar : number of characters on which the comparison must be -* done. -* -* Ouput parameters : -* -* Returned value : -* The function returns a signed integer which reports the result of -* the comparison : -* 0 if String1 = String2 or if NbByt is null ; -* >0 if String1 > String2 ; -* <0 if String1 < String2. -* -*********************************************************************/ -extern INT32 UST_Se_StrnCmp - (const char * const /* in / string1, - const char const /* in / string2, - const INT32 / in */ size); - - -/******************************************************************** -* SERVICE UST_Se_StrnCpy -******************************************************************** -* -* Fonction : -* Function : -* This service copies exactly the NbChar first characters of String2 -* (source) in String1 (destination), truncking String2 (source) or adding -* to -* String1 (destination) the character '\0' if necessary. -* If the number of characters to be copied (NbChar) is bigger than the -* number of -* characters of String2 (source), String1 (destination) is completed with -* le character '\0' until NbChar. -* If the number of characters to be copied (NbChar) is lower than the number -* of -* characters of String2 (source) AND bigger than the number of characters -* de -* String1 (destination), the character '\0' is inserted at end of copy. -* If those two conditions are not fulfilled, the character '\0' is not -* inserted at end of the copy. -* -* The result of the copy is stored in String1. -* If NbChar is null, String1 ramains unchanged. -* -* Input parameters : -* - String1 : address of the string to be crushed ; -* - String2 : address of the string to be copied ; -* - NbChar : number of characters to be copied. -* -* Ouput parameters : -* -* Returned code : -* -*********************************************************************/ -extern void UST_Se_StrnCpy - (CHAR * const /* out / dest, - const char const /* in / src, - const INT32 / in */ size); - - - -/******************************************************************** -* SERVICE UST_Me_Assert -******************************************************************** -* -* Fonction : -* assertion Macro -* -/ -# 16 "TCA_Automaton.i" 2 -# 1 "TCA_Automaton.h" 1 - - - - -/ - MACHINE TERMINALE TCA_Automaton -******************************************************************** -* Mnemonique : -* TCA -* -* Definition : -* TCA_Automaton is a terminal machine and is in charge of managing the states -* depending on the input events generated by TCR_FileReader or TCW_FileWriter. -* and also emitting the events based on the state transition. -* -* Particularites : -* AUCUNE -/ - -/ -TYPES, RESSOURCES, CONSTANTES EXPORTES -*********************************************************************/ - -typedef enum { -TCA_E_INIT=0, -TCA_E_TX_WAIT, -TCA_E_RX_WAIT, -TCA_E_TX_DATA, -TCA_E_RX_DATA -}TCA_Te_States; -/* -typedef enum{ -TCA_E_RD_BLK_KO, -TCA_E_WR_BLK_KO, -TCA_E_RD_BLK_OK, -TCA_E_WR_BLK_OK, -TCA_E_RD_FILE_REQ, -TCA_E_WR_FILE_REQ, -TCA_E_DATA, -TCA_E_TIMER_EXP, -TCA_E_OACK, -TCA_E_ACK, -TCA_E_BLK_SIZE_KO, -TCA_E_MAX_RETRY_REACHED, -TCA_E_DONE, -TCA_E_ERROR -}TCA_Te_Events; - -typedef enum{ -TCA_E_SEND_ERROR, -TCA_E_WR_BLK, -TCA_E_CLOSE_CONN, -TCA_E_START_TIMER, -TCA_E_RD_BLK, -TCA_E_SEND_WRQ, -TCA_E_SEND_RRQ, -TCA_E_SEND_ACK, -TCA_E_SEND_DATA, -TCA_E_RESEND -}TCA_Te_Emissions; - -typedef WORD32 TCA_Td_AutomatonInputs; - -typedef WORD32 TCA_Td_AutomatonOutputs; - -typedef struct{ -TCA_Td_AutomatonInputs InputEvents; -TCA_Td_AutomatonOutputs OutputEvents; -TCA_Te_States CurrentState; -}TCA_Ts_Automaton; -*/ -/******************************************************************** -SERVICES EXPORTES -/ - - - -/ -* SERVICE TCA_Se_Init -******************************************************************** -* -* Fonction : -* TCA_Se_Init Initializes the Client Automaton default state to INIT -* - Initialize the default maximum retry number -* -* In Parameters -* none -* -* Out Parameters -* Automaton: Automaton state information. -* -*********************************************************************/ -extern void TCA_Se_Init(); - //(TCA_Ts_Automaton * const /* out */ Automaton); - - -/******************************************************************** -* SERVICE TCA_Se_Reset -******************************************************************** -* -* Fonction : -* TCA_Se_Reset re-initialize the state to default, and turns off all the -* in and out events. -* -* Out Parameters -* Automaton: Automaton state information. -* -*********************************************************************/ -extern void TCA_Se_Reset(); - //(TCA_Ts_Automaton * const /* out */ Automaton); - - -/******************************************************************** -* SERVICE TCA_Se_Automate -******************************************************************** -* -* Fonction : -* TCA_Se_Automate evaluates the input events and change the state if necessary -* to next state -* and emits the out events. -* -* Out Parameters -* Automaton: Automaton state information. -* -*********************************************************************/ -extern void TCA_Se_Automate(); - //(TCA_Ts_Automaton * const /* in out */ Automaton); - - -/******************************************************************** -* SERVICE TCA_Se_SetEvent -******************************************************************** -* -* Fonction : -* TCA_Se_SetEvent asserts the given event. -* -* In Parameters -* Event input event raised. -* -* Out Parameters -* Automaton: Automaton state information. -* -*********************************************************************/ - -//extern void TCA_Se_SetEvent - //(const TCA_Te_Events /* in / Event, - //TCA_Ts_Automaton const /* out */ Automaton); - - -/******************************************************************** -* SERVICE TCA_Se_IsEventSet -******************************************************************** -* -* Fonction : -* TCA_Se_IsEvebtSet returns TRUE if the corresponding event is asserted, -* else FALSE. -* -* In Parameters -* Event: output event raised by automaton. -* -* Out Parameters -* Automaton: Automaton state information. -* -* Return Code -* returns TRUE if the corresponding event is asserted, else FALSE(BOOLEAN). -* -*********************************************************************/ -//extern BOOLEAN TCA_Se_IsEventSet - //(const TCA_Te_Emissions /* in / Event, - //const TCA_Ts_Automaton / in */ Automaton); -# 17 "TCA_Automaton.i" 2 -# 15 "TCA_Automaton.c" 2 - -/******************************************************************** -RESSOURCES et CONSTANTES EXPORTEES -/ - - - -// Input ports -int TCA_E_RD_BLK_KO=0; -int TCA_E_WR_BLK_KO=0; -int TCA_E_RD_BLK_OK=0; -int TCA_E_WR_BLK_OK=0; -int TCA_E_RD_FILE_REQ=0; -int TCA_E_WR_FILE_REQ=0; -int TCA_E_DATA=0; -int TCA_E_TIMER_EXP=0; -int TCA_E_OACK=0; -int TCA_E_ACK=0; -int TCA_E_BLK_SIZE_KO=0; -int TCA_E_MAX_RETRY_REACHED=0; -int TCA_E_DONE=0; -int TCA_E_ERROR=0; - -// Output ports -int TCA_E_SEND_ERROR=0; -int TCA_E_WR_BLK=0; -int TCA_E_CLOSE_CONN=0; -int TCA_E_START_TIMER=0; -int TCA_E_RD_BLK=0; -int TCA_E_SEND_WRQ=0; -int TCA_E_SEND_RRQ=0; -int TCA_E_SEND_ACK=0; -int TCA_E_SEND_DATA=0; -int TCA_E_RESEND=0; - -TCA_Te_States CurrentState; - -/ -TYPES, DONNEES, CONSTANTES INTERNES -/ - - - -/ -TYPES, DONNEES, CONSTANTES MANUELLES -/ - - - -/ -SERVICES INTERNES -/ -/ -* SERVICE TCA_Si_SetOutputEvent -******************************************************************** -* -* Fonction : -* TCA_Si_SetOutputEvent asserts output event. -* -*********************************************************************/ -//void TCA_Si_SetOutputEvent -//(const TCA_Te_Emissions /* in / Event,TCA_Ts_Automaton Automaton); - - -/******************************************************************** -* SERVICE TCA_Si_ClearOutputEvents -******************************************************************** -* -* Fonction : -* TCA_Si_ClearOutputEvents Clears all output events aserted. -* -*********************************************************************/ -void TCA_Si_ClearOutputEvents();//TCA_Ts_Automaton* /out/Automaton); - - -/******************************************************************** -* SERVICE TCA_Si_IsInputEventSet -******************************************************************** -* -* Fonction : -* TCA_Si_IsInputEventSet Returns TRUE if the given input event is -asserted, else returns FALSE. - -*********************************************************************/ -/* / -//BOOLEAN TCA_Si_IsInputEventSet(const TCA_Te_Events / in / Event, -// TCA_Ts_Automaton /out/Automaton); - -/******************************************************************** -* SERVICE TCA_Si_ClearInputEvents -******************************************************************** -* -* Fonction : -* TCA_Si_ClearInputEvents Clears all the input events -* -*********************************************************************/ -void TCA_Si_ClearInputEvents();//TCA_Ts_Automaton * /out/Automaton); - -/******************************************************************** -*CORPS DES SERVICES EXPORTES -*********************************************************************/ - -/$/ -/*$********************************************************************/ -/$ SERVICE TCA_Se_Init/ -/*$********************************************************************/ -/* Description -TCA_Se_Init Initializes the Client Automaton default state to INIT - - Initialize the default maximum retry number -* -* In Parameters -* none -* -* Out Parameters -* Automaton: Automaton state information. -* -* Flots de controle et de donnees -[initializes the automaton state and events to default values] - -* Contraintes : -*********************************************************************/ -void TCA_Se_Init() -//(TCA_Ts_Automaton * const /* out / Automaton) -{ - /initialize the automaton to default values/ - CurrentState = TCA_E_INIT; - - /clear input events/ - //Automaton->InputEvents = 0x0; - /clear output events/ - //Automaton->OutputEvents = 0x0; - - TCA_Si_ClearInputEvents(); - TCA_Si_ClearOutputEvents(); - -} -/$/ -/$********************************************************************/ -/$ SERVICE TCA_Se_Reset/ -/*$********************************************************************/ -/* Description -TCA_Se_Reset re-initialize the state to default, and turns off all the - in and out events. -* -* Out Parameters -* Automaton: Automaton state information. -* -* Flots de controle et de donnees -[clears all the input events and output events, reset state to INIT] - -* Contraintes : -*********************************************************************/ -void TCA_Se_Reset() -//(TCA_Ts_Automaton * const /* out / Automaton) -{ - /initialize the automaton to default values/ - //CurrentState = TCA_E_INIT; - /clear input events/ - //Automaton->InputEvents = 0x0; - /clear output events/ - //Automaton->OutputEvents = 0x0; - - /initialize the automaton to default values/ - CurrentState = TCA_E_INIT; - TCA_Si_ClearInputEvents(); - TCA_Si_ClearOutputEvents(); -} -/$/ -/$********************************************************************/ -/$ SERVICE TCA_Se_Automate/ -/*$********************************************************************/ -/* Description -TCA_Se_Automate evaluates the input events and change the state if necessary - to next state -* and emits the out events. -* -* Out Parameters -* Automaton: Automaton state information. -* -* Flots de controle et de donnees -[automates the input events depending on the current state of the automaton] - -* Contraintes : -*********************************************************************/ -/@ -@ requires TCA_E_RD_FILE_REQ==0 || TCA_E_RD_FILE_REQ==1; -@ requires TCA_E_WR_FILE_REQ==0 || TCA_E_WR_FILE_REQ==1; -@ requires TCA_E_DATA==0 || TCA_E_DATA==1; -@ requires TCA_E_ACK==0 || TCA_E_ACK==1; -@ requires TCA_E_TIMER_EXP==0 || TCA_E_TIMER_EXP==1; -@ requires TCA_E_WR_BLK_OK==0 || TCA_E_WR_BLK_OK==1; -@ requires TCA_E_RD_BLK_OK==0 || TCA_E_RD_BLK_OK==1; -@ requires TCA_E_RD_BLK_KO==0 || TCA_E_RD_BLK_KO==1; -@ requires TCA_E_WR_BLK_KO==0 || TCA_E_WR_BLK_KO==1; -@ requires TCA_E_BLK_SIZE_KO==0 || TCA_E_BLK_SIZE_KO==1; -@ requires TCA_E_MAX_RETRY_REACHED==0 || TCA_E_MAX_RETRY_REACHED==1; -@ requires TCA_E_DONE==0 || TCA_E_DONE==1; -@ requires TCA_E_OACK==0 || TCA_E_OACK==1; -@ requires TCA_E_ERROR==0 || TCA_E_ERROR==1; -@ requires TCA_E_SEND_RRQ==0 || TCA_E_SEND_RRQ==1; -@ requires TCA_E_SEND_WRQ==0 || TCA_E_SEND_WRQ==1; -@ requires TCA_E_START_TIMER==0 || TCA_E_START_TIMER==1; -@ requires TCA_E_SEND_DATA==0 || TCA_E_SEND_DATA==1; -@ requires TCA_E_CLOSE_CONN==0 || TCA_E_CLOSE_CONN==1; -@ requires TCA_E_RD_BLK==0 || TCA_E_RD_BLK==1; -@ requires TCA_E_WR_BLK==0 || TCA_E_WR_BLK==1; -@ requires TCA_E_RESEND==0 || TCA_E_RESEND==1; -@ requires TCA_E_SEND_ERROR==0 || TCA_E_SEND_ERROR==1; -@ requires TCA_E_SEND_ACK==0 || TCA_E_SEND_ACK==1; -@ behavior state_RX_WAIT: -@ assumes CurrentState==TCA_E_RX_WAIT; -@ ensures from_RX_WAIT_to_INIT2_1 : (\old(TCA_E_BLK_SIZE_KO)) && !(\old(TCA_E_OACK) && ! (\old(TCA_E_BLK_SIZE_KO))) ==> CurrentState==TCA_E_INIT; -@/ -void TCA_Se_Automate() -//(TCA_Ts_Automaton * const /* in out / Automaton) -{ - /temparry flag to store the event status/ - BOOLEAN TempFlag=FALSE; - - / Clear output events./ - TCA_Si_ClearOutputEvents();//Automaton); - - /automate the emission and chagne of state depending on the current state - * and input event./ - switch(CurrentState) - { - - - - case TCA_E_RX_WAIT: - /If the block size negotiation failed/ - if(TCA_E_BLK_SIZE_KO == TRUE) - { - / send error, close connection and change state to init/ - TCA_E_SEND_ERROR = TRUE; - - /raise close connectin event/ - TCA_E_CLOSE_CONN = TRUE; - - / change state to TCA_E_INIT/ - CurrentState = TCA_E_INIT; - } - /when OACK event is raised/ - if(TCA_E_OACK == TRUE) - { - /if block size is ok/ - if(!(TCA_E_BLK_SIZE_KO == TRUE)) - { - / raise send ACK and start timer event / - TCA_E_SEND_ACK = TRUE; - - /raise TCA_E_START_TIMER event/ - TCA_E_START_TIMER = TRUE; - } - - } - / when DATA event is raised/ - else if(TCA_E_DATA == TRUE) - { - - /if not final ack/ - if(!(TCA_E_DONE == TRUE)) - { - /raise write block event and change state to RX_DATA/ - TCA_E_WR_BLK = TRUE; - CurrentState = TCA_E_RX_DATA; - } - } - / when timer exp event is raised / - else if(TCA_E_TIMER_EXP == TRUE) - { - /store TCA_E_MAX_RETRY_REACHED status in to TempFlag/ - TempFlag = - (TCA_E_MAX_RETRY_REACHED == TRUE); - /if neither maximum retry reached nor transfer is completed/ - if(! (TempFlag==TRUE - || (TCA_E_DONE == TRUE))) - { - / raise resend event/ - TCA_E_RESEND = TRUE; - } - } - / wehen timer expire event is raised and / - else if(TCA_E_TIMER_EXP == TRUE) - { - TempFlag = - (TCA_E_MAX_RETRY_REACHED == TRUE); - /if either maximum retry reached or transfer is completed/ - if(TempFlag==TRUE - || (TCA_E_DONE == TRUE)) - { - /raise close connection and change state to INIT/ - TCA_E_CLOSE_CONN = TRUE; - - / change state to TCA_E_INIT/ - CurrentState = TCA_E_INIT; - } - - } - else - { - /Invalid input event./ - } - - break; - - default: - break; - } - - /clear all the input events as ther processing is comleted/ - TCA_Si_ClearInputEvents();//Automaton); -} -/$/ -/$********************************************************************/ -/$ SERVICE TCA_Se_SetEvent/ -/*$********************************************************************/ -/* Description -TCA_Se_SetEvent asserts the given event. - -* In Parameters -* Event input event raised. -* -* Out Parameters -* Automaton: Automaton state information. -* -* Flots de controle et de donnees -[set the corresponding event to TRUE, to say it is raised] - -* Contraintes : -*********************************************************************/ -//void TCA_Se_SetEvent -//(const TCA_Te_Events /* in / Event, -// TCA_Ts_Automaton const /* out / Automaton) -//{ -// / Set Event raised indication in Automaton->InputEvents / -// Automaton->InputEvents = (TCA_Td_AutomatonInputs) -// ((1<<(WORD32)Event)|Automaton->InputEvents); -// -//} -/$/ -/$********************************************************************/ -/$ SERVICE TCA_Se_IsEventSet/ -/*$********************************************************************/ -/* Description -TCA_Se_IsEvebtSet returns TRUE if the corresponding event is asserted, - else FALSE. -* -* In Parameters -* Event: output event raised by automaton. -* -* Out Parameters -* Automaton: Automaton state information. -* -* Return Code -* returns TRUE if the corresponding event is asserted, else FALSE. -* -* Flots de controle et de donnees -[returns TRUE if the requested event is raised] - -* Contraintes : -*********************************************************************/ -//BOOLEAN TCA_Se_IsEventSet -//(const TCA_Te_Emissions /* in / Event, -// const TCA_Ts_Automaton / in / Automaton) -//{ -// /TRUE if the corresponding event is asserted, else FALSE/ -// return (BOOLEAN)((0x0001) & (Automaton.OutputEvents>>(INT32)Event)); -//} - -/$*/ -/******************************************************************** -*CORPS DES SERVICES INTERNES -*********************************************************************/ -/$/ -/*$********************************************************************/ -/$ SERVICE TCA_Si_SetOutputEvent/ -/*$********************************************************************/ -/* Description -TCA_Si_SetOutputEvent asserts the given event in to output event list. - -* In Parameters -* Event output event raised. -* -* Flots de controle et de donnees -* AUCUN -* Contraintes : -*********************************************************************/ -//void TCA_Si_SetOutputEvent -//(const TCA_Te_Emissions /* in /Event,TCA_Ts_Automaton /out/ Automaton) -//{ -// -// /* Set Event raised indication in Automaton->InputEvents / -// Automaton->OutputEvents = (TCA_Td_AutomatonOutputs) -// ((1<<(WORD32)Event)|Automaton->OutputEvents); -// -//} - -/$/ -/$********************************************************************/ -/$ SERVICE TCA_Si_ClearOutputEvents/ -/*$********************************************************************/ -/* Description -TCA_Si_ClearOutputEvents clears output events list. - -* Flots de controle et de donnees -* AUCUN -* Contraintes : -*********************************************************************/ -/@ ensures (TCA_E_SEND_ERROR==0); - @ ensures (TCA_E_WR_BLK==0); - @ ensures (TCA_E_CLOSE_CONN==0); - @ ensures (TCA_E_START_TIMER==0); - @ ensures (TCA_E_RD_BLK==0); - @ ensures (TCA_E_SEND_WRQ==0); - @ ensures (TCA_E_SEND_RRQ==0); - @ ensures (TCA_E_SEND_ACK==0); - @ ensures (TCA_E_SEND_DATA==0); - @ ensures (TCA_E_RESEND==0); - @/ -void TCA_Si_ClearOutputEvents() -//(TCA_Ts_Automaton* /out/Automaton) -{ - - /* Cleare output events list / - //Automaton->OutputEvents = 0; - - TCA_E_SEND_ERROR=0; - TCA_E_WR_BLK=0; - TCA_E_CLOSE_CONN=0; - TCA_E_START_TIMER=0; - TCA_E_RD_BLK=0; - TCA_E_SEND_WRQ=0; - TCA_E_SEND_RRQ=0; - TCA_E_SEND_ACK=0; - TCA_E_SEND_DATA=0; - TCA_E_RESEND=0; -} - -/$/ -/$********************************************************************/ -/$ SERVICE TCA_Si_SetOutputEvent/ -/*$********************************************************************/ -/* Description -TCA_Se_IsEvebtSet returns TRUE if the corresponding event is asserted, - else FALSE. -* -* In Parameters -* Event: input event. -* -* Retur Code -* returns TRUE if the corresponding event is asserted, else FALSE -* -* Flots de controle et de donnees -* AUCUN -* Contraintes : -*********************************************************************/ -//BOOLEAN TCA_Si_IsInputEventSet -//(const TCA_Te_Events /* in / Event,TCA_Ts_Automaton/out/ Automaton) -//{ -// /TRUE if the corresponding event is asserted, else FALSE/ -// return ((BOOLEAN)((0x0001) & (Automaton->InputEvents>>(INT32)Event))); -// -//} - - -/$/ -/*$********************************************************************/ -/$ SERVICE TCA_Si_ClearInputEvents/ -/*$********************************************************************/ -/* Description -TCA_Si_ClearInputEvents clears input events list. - -* Flots de controle et de donnees -* AUCUN -* Contraintes : -*********************************************************************/ -/@ - @ ensures (TCA_E_RD_BLK_KO == 0); - @ ensures (TCA_E_WR_BLK_KO == 0); - @ ensures (TCA_E_RD_BLK_OK == 0); - @ ensures (TCA_E_WR_BLK_OK == 0); - @ ensures (TCA_E_RD_FILE_REQ == 0); - @ ensures (TCA_E_WR_FILE_REQ == 0); - @ ensures (TCA_E_DATA == 0); - @ ensures (TCA_E_TIMER_EXP == 0); - @ ensures (TCA_E_OACK == 0); - @ ensures (TCA_E_ACK == 0); - @ ensures (TCA_E_BLK_SIZE_KO == 0); - @ ensures (TCA_E_MAX_RETRY_REACHED == 0); - @ ensures (TCA_E_DONE == 0); - @ ensures (TCA_E_ERROR == 0); - @/ -void TCA_Si_ClearInputEvents()//TCA_Ts_Automaton/out/ Automaton) -{ - - / Cleare output events list / - //Automaton->InputEvents = 0; - - TCA_E_RD_BLK_KO=0; - TCA_E_WR_BLK_KO=0; - TCA_E_RD_BLK_OK=0; - TCA_E_WR_BLK_OK=0; - TCA_E_RD_FILE_REQ=0; - TCA_E_WR_FILE_REQ=0; - TCA_E_DATA=0; - TCA_E_TIMER_EXP=0; - TCA_E_OACK=0; - TCA_E_ACK=0; - TCA_E_BLK_SIZE_KO=0; - TCA_E_MAX_RETRY_REACHED=0; - TCA_E_DONE=0; - TCA_E_ERROR=0; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/test_result1.c frama-c-20111001+nitrogen+dfsg/tests/wp/test_result1.c --- frama-c-20110201+carbon+dfsg/tests/wp/test_result1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/test_result1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -int r; - -/@ ensures r == 1; / -int g2() { - r = (int)malloc(sizeof(int)); - return r; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/threat.c frama-c-20111001+nitrogen+dfsg/tests/wp/threat.c --- frama-c-20110201+carbon+dfsg/tests/wp/threat.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/threat.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -int main(int x, int y) { - - if (x >= 10) x = 10; else if (x <= 0) x = 0; - - if (xx-10 > 0) - //@ assert (xx-8) != 0; - return 1/(xx-8); - - return 0; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/Type2Ex1.c frama-c-20111001+nitrogen+dfsg/tests/wp/Type2Ex1.c --- frama-c-20110201+carbon+dfsg/tests/wp/Type2Ex1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/Type2Ex1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -/* run.config - DONTRUN: test under construction -/ - -char Buffer[1040] ; - -// note: properties named "oracle_ko" are not true ! -/@ - -assigns Buffer[..]; - -exits never: oracle_ok: \false; - -behavior b1: - ensures p1: oracle_ok: - \forall integer k ; 0 <= k < 3 - ==> Buffer[k] == \old(Buffer[k]); - ensures p1_ko: oracle_ko: - \forall integer k ; 0 <= k < 4 - ==> Buffer[k] == \old(Buffer[k]); - -behavior b2: - ensures p2: oracle_ok: - \forall integer k ; 0 <= k < nb - ==> Buffer[k+3] == \old(buffer[k]); - ensures p2_ko: oracle_ko: - \forall integer k ; 0 <= k < nb - ==> Buffer[k] == \old(buffer[k]); - -behavior b3: - ensures p3: oracle_ok: - \forall integer k ; nb+3 <= k < 1040 - ==> Buffer[k] == \old(Buffer[k]); - ensures p3_ko: oracle_ko: - \forall integer k ; nb <= k < 1040 - ==> Buffer[k] == \old(Buffer[k]); - - - / -void Type2Ex1 (const char buffer, int nb) -{ - int i ; - /@ loop assigns i, Buffer[3..(3+(i-1))]; - loop invariant i0: oracle_ok: 0 <= i && (0 <= nb ==> i <= nb) ; - for b1: loop invariant b1: oracle_ok: - \forall integer k ; 0 <= k < 3 - ==> Buffer[k] == \at(Buffer[k],Pre); - for b2: loop invariant b2: oracle_ok: - \forall integer k ; 0 <= k Buffer[k+3] == \at(buffer[k],Pre); - for b3: loop invariant b3: oracle_ok: - \forall integer k ; nb+3 <= k < 1040 - ==> Buffer[k] == \at(Buffer[k],Pre); - loop variant decr: oracle_ok: nb - i ; - / - for (i = 0 ; i < nb ; i++) - Buffer[3+i] = buffer[i] ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/Type3Ex3.c frama-c-20111001+nitrogen+dfsg/tests/wp/Type3Ex3.c --- frama-c-20110201+carbon+dfsg/tests/wp/Type3Ex3.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/Type3Ex3.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -/* run.config - DONTRUN: test under construction -/ - -typedef float Numeric ; -/@ assigns \nothing ; - @/ -Numeric f (Numeric num1,Numeric num1) ; - -typedef const struct { Numeric i; Numeric j;} Numeric2; -void Type3Ex3 (int e1, Numeric p1, Numeric2 t1[], Numeric t2[]) { - - int s ; - while ((s < (sizeof (t1) / sizeof (Numeric2)) - 2) && - (e1 >= t1[s + 1].i)) - //@ assert \false; - s = s + 1 ; - p1 = f (e1 - t1[s].i, t2[s]) + t1[s].j ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/Type4Ex2.c frama-c-20111001+nitrogen+dfsg/tests/wp/Type4Ex2.c --- frama-c-20110201+carbon+dfsg/tests/wp/Type4Ex2.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/Type4Ex2.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -/ run.config - DONTRUN: test under construction -/ - -/@ assigns \nothing; - exits never: oracle_ok: \false ; -// behavior found: -// assumes \exists int k ; 0 <= k < 15 && t1[k] != t2[k] ; -// ensures oracle_ok: \result == 0 ; -// behavior not_found: -// assumes \forall int k ; 0 <= k < 15 ==> t1[k] == t2[k] ; -// ensures oracle_ok: \result == 1 ; -// complete behaviors found, not_found ; -// disjoint behaviors found, not_found ; - / -int Type4Ex2 (int t1[], int t2[]) { - int i ; - -// /@ loop assigns i; -// loop invariant I0: oracle_ok: 0 <= i <= 15 ; -// loop invariant not_yet_found: oracle_ok: \forall int k ; 0 <= k t1[k] == t2[k] ; -// / - for (i = 0 ; i < 15 ; i++) - /@ assigns \nothing; - / - if (t1[i] != t2[i]) - return 0 ; - return 1 ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/Type6Ex1.c frama-c-20111001+nitrogen+dfsg/tests/wp/Type6Ex1.c --- frama-c-20110201+carbon+dfsg/tests/wp/Type6Ex1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/Type6Ex1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -/ run.config - DONTRUN: test under construction -/ - -/@ axiomatic DISTANCE_INT { - @ logic int Distance_int (int x, int y) ; - @ axiom r: - \forall int x ; - Distance_int (x,x) == 0 ; - @ axiom s: - \forall int x, y ; - Distance_int (x,y) + Distance_int (y,x) == 0 ; - @ } - @/ - -/@ assigns \nothing ; - ensures result: \result == Distance_int (val1, val2) ; - exits never: \false ; - @/ -int distance_int (int val1, int val2) ; - -/@ assigns \nothing ; - exits never: oracle_ok: \false ; - - @ behavior not_found: - assumes \forall int k ; 0 <= k < 10 ==> 0 == Distance_int (tab[k], tabref[k]) ; - ensures oracle_ok: \result == 1 ; - - @ behavior found: - assumes \exists int k ; 0 <= k < 10 && 0 != Distance_int (tab[k], tabref[k]) ; - ensures oracle_ok: \result == 0 ; - - @ complete behaviors not_found, found ; - @ disjoint behaviors not_found, found ; - @/ -char Type6Ex1(int tab [10], int tabref[10]) { - int i = 0 ; - char control_ok = 1 ; - - /@ loop assigns i, control_ok ; - loop invariant I0: oracle_ok: 0 <= i <= 10 ; - loop invariant C0: oracle_ok: 0 == control_ok || control_ok == 1 ; - loop invariant I0_C0: oracle_ok: 0 == control_ok ==> i < 10 ; - loop invariant not_yet_found: oracle_ok: - control_ok==1 ==> \forall int k ; 0 <= k 0 == Distance_int (tab[k], tabref[k]) ; - loop invariant not_found_before: oracle_ok: - control_ok==0 ==> 0 != Distance_int (tab[i], tabref[i]) ; - @ loop variant decr: oracle_ok: (control_ok==1) ? (10 - i) : 0; - @/ - while (i < 10 && control_ok) - if (0 == distance_int (tab[i], tabref[i])) - i++ ; - else - control_ok = 0 ; - return control_ok ; -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_acsl.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_acsl.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_acsl.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_acsl.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ - -// Be carreful : this is not the real definition (TODO : change that) -int NULL = (int) 0; - //@ global invariant null_inv : NULL == \null; - -int G, X, T[10]; - -void tnull () { - int p; - p = &G; - //@ assert (p != \null) ; - p = NULL; - //@ assert (p == \null) ; -} - -// @ ensures \result == \min(x, y); TODO : at the moment \min has a wrong type -int min (int x, int y) { - return x < y ? x : y; -} - -/@ ensures \separated (\result, &X); / -int * ptrX (int * p) { - p = &G; - return p; -} - -/@ requires 0 < n; - ensures \result <= n; -/ -int loop (int n) { - int i, s = 0; - /@ loop invariant s <= i && 0<= i <= n; - loop assigns i, s; - loop variant (n - i); - / - for (i = 0; i < n; i++) { - if (T[i] == 0) s++; - } - - return s; -} - -//@ ensures \result <= n; -int stmt_contract (int n) { - int i, s = 0; - /@ ensures s <= n; - assigns i, s; - / - //@ loop invariant s <= i && 0<= i <= n; - for (i = 0; i < n; i++) { - if (T[i] == 0) s++; - } - - return s; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_arith.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_arith.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_arith.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_arith.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -/* run.config - OPT: -journal-disable -wp -wp-model Hoare -wp-proof none -wp-print -/ - -/ run.config_phoare - OPT: -journal-disable -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -// Tests on arithmertic problem : only needs Hoare. -// See [wp_bits.c] for examples on bit representation. - - -/@ behavior KO : ensures \result == 10; - behavior ok : ensures \result == 0; -/ -char implicit_char_cast (void) { - unsigned char i = 0; - signed char x = -1; - // in this example, both [char] are first promoted to [int], - // so the comparition gives the intuitive result (see [implicit_cast] below) - return (x < i) ? 0 : 10; -} - -/@ behavior ok : ensures \result == 10; - behavior KO : ensures \result == 0; -/ -int implicit_cast (void) { - unsigned int i = 0; - signed int x = -1; - // in this example, both variables are converted to [unsigned int], - // so the result of the comparison looks strange... - return (x < i) ? 0 : 10; -} - -/@ behavior KO : ensures \result < 0; - behavior ok : ensures \result >= 0; -/ -unsigned char cast_sgn_usgn (void) { - char x = -1; - return x; -} - -// This one is ok. -unsigned char uchar_range (unsigned char i) { - //@ assert i >= 0; - //@ assert i <= 255; - return i; -} - - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_array.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_array.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_array.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_array.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ - -typedef struct S { - int r ; - int f[7] ; - int g[5] ; -} ; - - -int a[10] ; -struct S s ; - -void f(void) -{ - //@assert s.g == s.f + 7 ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_assign.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_assign.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_assign.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_assign.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,159 +0,0 @@ -/ run.config_phoare - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ -/ run.config_pruntime - OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-proof simplify -wp-print -wp-verbose 2 -/ - - -int C; - -/@ behavior ok : - ensures C == \at(c, Pre); - ensures \at(c, Pre) == c; // param cannot be modified by a function. - behavior ko : - ensures C == \at(C, Pre); // false : global var has been modified. -/ -void f0 (int x,int c) { - C = c; - c = x; - c++; - //@ assert x == c-1; -} - -//@ ensures \result == x+3; -char fchar (char x) { - char y = 3; - return x+y; -} - -// simplest example of assignment... -int f1() { - int x; - x = 0; - x++; - //@ assert x == 1; - return 0; -} - -/@ requires y == 12 ; / -int f2(int y) { - int x; - x = y; - //@ assert x == 12; - if (x == 0) x++; else x = 1; - //@ assert x == 1; - return 0; -} - -//@ ensures (x < 3) ==> \result == 0; -int f3a (int x) { - return (x > 3) ? 1 : 0; -} - -//@ ensures (x < 3) ==> \result == 0; -int f3b (int x) { - int c = (x > 3); - return c; -} - -/@ ensures (x != 0) ==> \result == 1; - ensures (x == 0) ==> \result == 0; - / -int f3c (int x) { - return x ? 1 : 0; -} - -struct Ts {int x; int y; }; -struct Tstr {int a; struct Ts s; int t[10]; struct Tstr p; } S; - -/@ ensures S.a == x ; - ensures S.p == \old(S.p) ; - ensures S == { \old(S) \with .a = x }; - / -void rw_int_field (int x) { - S.a = x; -} -//@ ensures S.s.x == x && S.s == { \old(S.s) \with .x = x }; -void rw_field_field (int x) { - S.s.x = x; -} -/@ ensures S.a == \old(S.a) && S.t[i] == x; - // TODO: ensures S == { \old(S) \with .t[i] = x }; -/ -void rw_tab_field (int i, int x) { - S.t[i] = x; -} -/@ requires S.p == &S || \separated (S.p, &S); - @ ensures S.p->a == x ; - @ ensures \forall int i; ((S.p)).t[i] == \old(((S.p)).t[i]); - / -void rw_ptr_field (int x) { - S.p->a = x; -} - -int T[10]; - -/@ ensures T[i] == x; - ensures \forall int j; i != j ==> T[j] == \old(T[j]); - ensures T == { \old(T) \with [i] = x}; -/ -void rw_array_elem (int i, int x) { - T[i] = x; -} - -int * P; - -//@ ensures P == x && P == \old(P); -void rw_pointer (int x) { - P = x; -} - -/@ requires \valid(P+i) && \separated(&P, P+i); - @ ensures (P + i) == x && P == \old(P); - @ ensures \forall int j; i != j ==> (P + j) == \old((P + j)); -/ -void rw_shift_pointer (int i, int x) { - (P+i) = x; -} - -/@ ensures ko: \forall int k; k == i+j ==> (P + k) == x; - ensures ok1: \forall int k; k == i+j ==> (\old(P) + k) == x; - behavior ok: - assumes \valid (P+i+j); - ensures ok2: \forall int k; k == i+j ==> (P + k) == x; -/ -void rw_shift_shift_pointer (int i, int j, int x) { - (P+i+j) = x; -} - -// Notice that there is no real indirect access : should be checked by M0... -/@ ensures T[i+j] == x; - @ ensures (T+(i+j)) == x; - @ ensures (T+i+j) == x; -/ -void rm_shift_array_elem (int i, int j, int x) { - (T+i+j) = x; -} - -// No indirect access -//@ ensures \result == &(T[i]); -int return_ptr (int i) { - return T+i; -} - -// No indirect access -//@ ensures P == T+(i+1); -void assign_pointer (int i) { - P = T+i; - P++; -} - -// No indirect access -//@ ensures \result == &(S.t[1]); -int * return_St1 (void) { - int * p = S.t; - return p+1; -} - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_behav.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_behav.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_behav.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_behav.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ - -/* run.config_phoare - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-fct assert_needed -wp-prop ok_with_hyp -wp-print -wp-verbose 2 - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -wp-prop ko1 -OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -wp-prop e1 -COMMENT: next test should be elsewhere in a wp_options.c test file because it is made to test -wp-prop for une assign property (nothing to do with phoare...) -OPT: -journal-disable -rte -wp -wp-model Store -wp-proof alt-ergo -wp-print -wp-verbose 2 -wp-prop asgn_ok -wp-fct stmt_contract_assigns -/ - -int X, Y, Z; - -/@ - @ ensures \result > x; - @ behavior x1: - @ assumes x == 1; - @ ensures \result == 3; - @ behavior x2: - @ assumes x == 2; - @ ensures \result == 4; - @ -/ -int f (int x) { - x++; - //@ for x1: assert x == 2; - //@ for x2: assert x == 3; - return x+1; -} - -/@ - behavior bx : - assumes x <= y; - ensures \result == x; - behavior by : - assumes x > y; - ensures \result == y; - complete behaviors bx, by; - disjoint behaviors bx, by; -/ -int min (int x, int y) { - return (x < y) ? x : y; -} - -/@ requires n != 0; - behavior pos : - assumes n > 0; - ensures \result == x/n; - behavior neg : - assumes n < 0; - ensures \result == x/-n; - complete behaviors pos, neg; // notice that this needs the requires hyp -/ -int bhv (int x, int n) { - n = (n<0) ? -n : n; - return x/n; -} - -/@ behavior ok: ensures \result > 0; - behavior ko : ensures \result > 2; - behavior ko_without_asgn : ensures \result > Y; -/ -int stmt_contract (int c) { - int x = 0; - Y = 0; - - /@ requires x == 0; - @ ensures x > 0; - / - if (c) - x = 3; - else - x = 5; - return x; -} - -//@ ensures \result >= 0; -int stmt_contract_label (int c) { - int x = 0; - - //@ ensures x >= \old(x); - if (c) x++; - - return x; -} - -/@ behavior ok: ensures \result > 0; - behavior ko : ensures \result > 2; - behavior ok_asgn : ensures \result > Y; -/ -int stmt_contract_assigns (int c) { - int x = 0; - Y = 0; - - /@ requires x == 0; - @ ensures x > 0; - @ assigns asgn_ok: x; - / - if (c) - x = 3; - else - x = 5; - return x; -} - -int local_named_behavior (int x) { - int y = 3; - /@ behavior xpos : - assumes x > 0; - ensures x > 3; - / - x += y; - return x; -} - -void assert_needed (int x) { - //@ assert ko : x > 0; - int a = 0; - a += x; - //@ assert ok_with_hyp : a > 0; -} - -/ we shouldn't be able to prove ko1 from ko2 and then ko2 from ko1 / -/@ ensures ko1 : \result == x+1; - ensures ko2 : \result == x+1; -/ -int bts0513 (int x) { - return x; -} - -//@ assigns X, Y; -void unknown (int, int); - -//@ ensures \result > X; -int stmt_assigns (int a) { - int x = 0; - int y = 3; - X = x; - //@ assigns Y; - unknown (x, y); - x = x+1; - return x; -} - -int T[10]; - -// use Inv as Hyp for Bhp props -/@ requires n < 10; - behavior b1 : assumes 0<n; ensures e1: T[0] == 0; - / -void razT (int n) { - - //@ loop invariant \forall int k; 0<= k T[k] == 0; - for (int i = 0; i < n; i++) - T[i] = 0; -} - -//@ ensures ok_with_hoare: T[1] == \old(T[1]); -int more_stmt_assigns (int x) { - x = 0; - //@ behavior blk: assigns x, T[x]; - { - T[x] = 1; - x = 1; - } - return x; -} -//============================================================================== diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_bits.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_bits.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_bits.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_bits.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ - -void test_bw_and() { - //@ assert (3&1) == 1; -} - -//@ ensures \result == ~1; -int main() -{ - char c1 = 1, c2 = 2; - char c3,c4,c5,c6,c7,c8; - c3 = c1 & c2; - //@ assert c3 == 0 ; - c4 = c1 | c2; - //@ assert c4 == 3 ; - c5 = c1 ^ c2; - //@ assert c5 == 3 ; - c6 = ~c1; - //@ assert c6 == 254 ; - c7 = c1<<2; - //@ assert c7 == 4 ; - c8 = c1>>2; - //@ assert c8 == 0; - return (1^-1); -} - - - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_call.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_call.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_call.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_call.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,180 +0,0 @@ -/ run.config_phoare - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 - OPT: -rte -journal-disable -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -struct Ts { int a; int b; }; -int G; -struct Ts S; -int P; -int T[10]; -int X; - -//------------------------------------------------------------------------------ -/@ - requires \true; - assigns G, S.b; - ensures G == \old(G) + x + 1 - && S.b == \old(S.b) + 1 - && \result == x + 1; -/ -int add_G (int x) { - x++; - G += x ; - S.b++; - return x; -} - -/@ - requires G == 0; - ensures G == 6 && S.a == 1 && S.b == 1 && \result == 6; -/ -int main(void) { - int r; - - S.a = 1; - S.b = 0; - - r = add_G (5); - - return r; -} -//------------------------------------------------------------------------------ - -// this is to test the assigns order : T[X] is T[\old(X)] ! -//@ assigns T[X], T[X+1], X; -void f (int x) { - T[X] = 0; - T[X+1] = 0; - X = x; -} - -// Be carreful : wrong translation of quantification in M2 -//@ ensures (\forall int i; 2 <= i < 10 ==> T[i] == \old(T[i])); -void call_f (void) { - int a = 3; - X = 0; - f (a); -} - -/@ ensures ko0: (T[0] == \old(T[0])); //false - ensures ko1: (T[1] == \old(T[1])); // false - ensures ok: (T[2] == \old(T[2])); //true - / -void call_f_1 (void) { - int a = 3; - X = 0; - f (a); -} - -//@ assigns T[m..M]; -void array_range (int m, int M); - -/@ ensures ok: (T[1] == \old(T[1])); - ensures ko: (T[5] == \old(T[5])); - assigns T[2..5]; -/ -void call_array_range (void) { - int i = 2; - int j = 5; - array_range (i, j); -} - -//------------------------------------------------------------------------------ -/* This is to test that M0 is able to handle a call with a pointer parameter - * as long as it takes an address as argument. / -/@ requires \valid(p); - ensures p == \old(p) + 1; - assigns p; -/ -void incr (int * p) { - (p) ++; -} -//@ ensures \result == x + 1; -int call_incr (int x) { - incr (&x); - return x; -} -//@ ensures S.a == \old(S.a) + 1; -void call_incr_on_S (void) { - incr (&(S.a)); -} -//@ ensures T[i] == \old(T[i]) + 1; -void call_incr_on_Ti (int i) { - incr (T+i); -} -//@ ensures T[0] == \old(T[0]) + 1; -void call_incr_on_T (void) { - incr (T); -} -//------------------------------------------------------------------------------ -// This is to test [assigns \nothing] -//@ assigns \nothing; -void print (int); - -//@ ensures \result == \old(X) + x; -int just_print (int x) { - print (x); - return X + x; -} -//------------------------------------------------------------------------------ -// This is to test call when assigns are not specified. -// We have to provide a body, else the kernel add a default assigns nothing ! -void unknown (void) { return; } - -// TODO : this test is wrong at the moment ! -/@ -@ ensures ko: X == \old(X); - // this one is not provable since we don't know whether [unknown] modifies X -@ ensures ok: \result == X; -/ -int call_unknown (void) { - unknown (); - return X; -} -//------------------------------------------------------------------------------ - -/@ - requires x >0 ; - ensures \result == x; - / - -int f1 (int x) -{ - return x; -} - -/@ ensures \result == 1; - / -int call_f1 (void) -{ int a = 1 ; return f1(a);} - -//------------------------------------------------------------------------------ -// This is to check that the result is processed even if it is not specified. - -//@ assigns \nothing; -int unknown_result (void); - -//@ ensures KO : \result == 0; -int call_unknown_result (void) { - int x = 0; - x = unknown_result (); - return x; -} -//------------------------------------------------------------------------------ -// This is to check that the result is correctly processed -// even if it is specified in 2 post-conditions. - -/@ assigns \nothing; - ensures \result >= 0; - ensures \result < 10; -/ -int spec2_result (void); - -//@ ensures ok : \result < 20; -int call_spec2_result (void) { - int x = 0; - x = spec2_result (); - return x; -} -//------------------------------------------------------------------------------ diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_call_ptr.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_call_ptr.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_call_ptr.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_call_ptr.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -/ assigns p; / -int * P; -/@ - ensures P == 0; -/ -void razP (void) { - P = 0; -} -/@ - ensures p == 0; -/ -void raz (int p) { - p = 0; -} -/@ assigns p; - ensures p == \old(p) + 1; -/ -void incr (int * p) { - (p)++; -} - -//@ ensures \result == 0; -int call_raz (void) { - int x; - raz (&x); - return x; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_caveat_subst.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_caveat_subst.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_caveat_subst.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_caveat_subst.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ - -/ - model name : UnsafeCaveat - kind : Positive - bhv : first part Provable; last part not yet finished -/ - -int X; -int P; - -void var_subst_const (void) { - int x = 3; - //@ assert ok: x == 3; -} - -void var_subst_var (int x) { - int y = x + 1; - //@ assert ok: y == x + 1; - x = x + 1; - //@ assert ok: y == x; -} -void assign_ptr (void) { - int x; - int * p = &x; - //@ assert ok: p == &x; -} -//@ ensures ok: \result == &X; -int * return_addr (void) { - return &X; -} - -//@ ensures should_be_ok: p == 3; -void ptr_subst (int p) { - p = 3; - //@ assert ok: p == 3; -} -void ptr_on_var (void) { - int x = 0; - int * p = &x; - //@ assert ok1: p == 0; - p = 3; - //@ assert ok2: p == 3; - //@ assert not_supported: x == 3; - //@ assert unsafe_err_ok: x == 0; -} -//@ ensures should_be_ok: \result == p; -int read_ptr (int * p) { - int y = p; - //@ assert ok: y == p; - return y; -} -int read_ptr_shift (int * p) { - int i = 3; - int y = (p + i); - //@ assert ok: y == (p+3); - return y; -} -void shift_ptr (int * p) { - p = 1; -L: p++; - p = 2; - //@ assert ok1: p == 2; - //@ assert ok2: (p-1) == 1; - //@ assert not_supported: \at(p, Pre)[1] == 2; - //@ assert ok3: \at(p, L) == 1; -} - -struct Tstr { int a; int b; int p; int t[10]; }; - -void caveat_havoc_field (struct Tstr * p) { - //@ assigns p->a; - { - p->a = 0; - } - //@ assert ok1: p->t[1] == \at(p->t[1], Pre); - //@ assert ok2: p->b == \at(p->b, Pre); - //@ assert KO: p->a == 0; // not provable this because of stmt spec -} - -void caveat_havoc_shift (int * p) { - //@ assigns p[0]; - { - p[0] = 0; - } - //@ assert ok_with_caveat: p[1] == \at(p[1], Pre); - //@ assert KO: p[0] == 0; -} -void caveat_havoc_range (int * p) { - //@ assigns p[1..3]; - { - p[1] = 0; p[3] = 0; - } - //@ assert ok_with_caveat: p[0] == \at(p[0], Pre); - //@ assert KO: p[1] == 0; // not provable this because of stmt spec -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_exit.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_exit.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_exit.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_exit.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,94 +0,0 @@ -// -//------ example from BTS #312 -/@ exits never_exits: oracle_ok: \false; - behavior oracle_ko : - ensures oracle_ko: \false; // <- invalid property -/ -int main() { - return 1; -} - -/@ assigns \nothing ; - ensures never_returns: \false; - exits exit_status: \exit_status==status; - / -extern void exit(int status); - -int X ; -/@ behavior never_exits: - assumes x>=0; - exits never_returns: oracle_ok: \false; - behavior never_returns: - assumes x<0; - assigns \nothing ; - ensures never_returns: oracle_ok: \false; - exits exit_status: oracle_ok: \exit_status==1; - behavior oracle_ko : - assumes x<0; - exits oracle_ko: \false; // <- invalid property -/ -int may_exit(int x) { - if (x < 0) - exit(1); - X = 1; - return 0 ; -} - -/@ behavior never_returns : - assumes x<0; - assigns oracle_ok: X; - behavior all : - assigns oracle_ok: X; - ensures result_value: oracle_ok: \result == 0; - exits exit_status: oracle_ok: \exit_status==1; - behavior oracle_ko: - assumes x<0; - assigns \nothing ; // <- invalid property - behavior oracle_bis_ko : - ensures oracle_ko: \false; // <- invalid property - exits oracle_ko: \false; // <- invalid property -/ -int may_exit_bis(int x) { - X = 1; - if (x < 0) - exit(1); - return 0 ; -} - -/@ assigns \nothing ; - @ ensures never_returns: \false ; - @ exits exit_status: \exit_status == status ; - @ / -void exit (int status); -int status ; - -/@ assigns oracle_ok: status ; - @ exits oracle_ok: ! cond && \exit_status == 1 && status == val ; - @ / -void may_exit2 ( int cond , int val ) { - if (! cond ) { - status = val ; - exit (1); - } -} - -int stmt_never_exit (int c) { - int x; - - /@behavior ok: exits oracle_ok: 1 == 2; / - if (c) x = 1; - else x = 0; - - return x; -} - -int stmt_may_exit (int c) { - int x; - - /@behavior ok: exits oracle_ok: c && \exit_status == 1; / - if (c) exit (1); - else x = 0; - return x; -} -// - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_froms.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_froms.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_froms.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_froms.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,125 +0,0 @@ -/* run.config - DONTRUN: not available for Carbon release. - OPT: -wp -wp-froms -wp-print -/ - -/@ axiomatic A { - logic int D_FI_fext_1 (int c, int x, int y); - logic char test (char x); - } -/ - -struct Tstr {int a; int b; int c; } S; -int x ,y ,z , p ; -int T[100]; - -/@ - assigns \result \from c, x, y; - assigns x \from c, y; - behavior c_true : - assumes c != 0; - assigns x \from \nothing; - assigns \result \from x; - behavior c_false: - assumes c == 0; - assigns x \from y; - assigns \result \from y; -/ -int fh (int c) { - int a = c ? x : y; - x = c ? 0 : a; - return a; -} -/@ - assigns \result \from c, x, y; - assigns x \from c, y; -/ -int fext (int c); - -/@ - assigns \result \from c, x, y; - assigns x \from c, y; - assigns y \from y; -/ -int call (int c) { - int xa; - c++; - xa = fext (c); - y++; - return xa; -} - -int unknown (int); - -//@ assigns \result \from x, y; // test comment... -int spec () { - int a = 0; - int b = x; - - //@ assigns b \from y, a; - if (y > 0) - b = unknown (a); - - return b; -} - -/@ assigns \result \from x, n; -/ -int loop (int n) { - int s = 0; - /@ loop assigns s \from i, x; - loop assigns i \from i; - / - for (int i = 0; i < n; i++) { - s += x; - } - return s; -} - -int loop2 (int n) { - int s = 0; - /@ loop assigns s \from s, T[0..(i-1)]; - @ loop assigns T[0..(i-1)] \from \nothing; - @ loop assigns i \from i; - / - for (int i = 0; i < n; i++) { - s += T[i]; - T[i] = 0; - } - return s; -} - -/@ assigns \result \from S; -/ -int * maxS (void) { - int * p = &(S.a); - if (p < S.b) p = &(S.b); - if (p < S.c) p = &(S.c); - return p; -} - - -/@ - assigns x \from c , y , x ; - assigns z \from c , x , z ; - assigns p \from c ; - - behavior c_true : - assumes c ; - assigns x \from y ; - assigns p \from \nothing ; - - behavior c_false : // et �a behavior - assumes ! c ; - assigns z \from x ; - assigns p \from \nothing ; -/ -void f ( int c ) { - if ( c ) p = & y ; - else p = & z ; - - if (! c ) * p = x + 1; - else x = * p + 1; -} - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_globs.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_globs.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_globs.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_globs.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -/@ logic boolean ok0 (integer i) = (0<= i) ; - @ logic boolean ok1 (integer i) = (i <= 10) ; - @ logic boolean ok (integer i) = ok0 (i) && ok1 (i) ; - / - -//@ predicate is_ok (int i) = (0 <= i && i <= 10) ; - -/* TODO : test ok with GUI but incorrect interpretation of alt-erdo results - * with why-dp... - / - -/@ behavior b_logic : ensures ok (\result); - @ behavior b_predicate : ensures is_ok (\result); -/ -int test (int x) { - if (x < 0) return 0; - //@ for b_logic : assert ok0 (x); - if (10 < x) return 10; - //@ for b_logic : assert ok1 (x); - return x; -} - -//WARNING : predicate pos_at{L} (integer n) = (0<= n) ; -// doesn't means : 0 <= \at(n, L) ! -// because 'n' is a value; it is not related to a memory state... - -//@ predicate positive (integer n) = (0 < n) ; - -/@ ensures positive (x) ==> positive (\result); - / -int labpred (int x) { - return x+1; -} - -int G; - -//@ predicate gtG_at{L} (integer n) = (G < n) ; - -/@ ensures gtG_at{Old}(x) ==> gtG_at (\result); - / -int labpredGat (int x) { - G--; - return x-1; -} - -//@ predicate Gincr{L1,L2} = (\at(G, L1) < \at(G, L2)) ; - -/@ requires positive(x); - @ ensures Gincr{Old,Here}; - / -void labpred2 (int x) { - G += x; -} - - -#if 0 -/@ axiomatic A1 { - predicate ok_with_G{L}(integer n) reads G ; - axiom gt_ok{L} : - \forall integer x; x > \at(G,L) ==> ok_with_G{L}(x); - } -/ -/@ axiomatic A2 {/ - predicate biggerG{L1, L2}(integer n) reads G ; - axiom ax_biggerG {L1,L2} : - \forall integer x; \at(G,L1) + x <= \at(G,L2) ==> biggerG{L1,L2}(x); - / - } -/ -#endif - -int T [10]; - -//@ predicate Tn{LT, LG}(integer i) = \at(T[\at(G,LG)], LT) > i; - -void testTn () { - T[G] = 1; - G ++; - //@ assert Tn{Here,Pre}(0); -} -//------------------------------------------------------------------------------ -// Logic functions + axioms with label -//@ logic boolean eq_ptr{L} (int p, integer x) = p == x; - -/@ requires \valid (p); - behavior test: assumes eq_ptr (p, 3); ensures \result == 3; -/ -int read_p (int p) { - return p; -} -//------------------------------------------------------------------------------ -/@ axiomatic Cpt { - @ - @ logic integer cpt_le_u{L} (int t, integer u, integer n, integer m); - @ - @ axiom c1{L} : \forall int t, integer u, integer i; - @ i >= 0 && u >= t[i] ==> - @ cpt_le_u{L}(t, u, 0, i) == cpt_le_u{L}(t, u, 0, i-1) + 1; - @ - @ axiom c2{L} : \forall int t, integer u, integer i; - @ i >= 0 && u < t[i] ==> - @ cpt_le_u{L}(t, u, 0, i) == cpt_le_u{L}(t, u, 0, i-1); - @ - @ axiom c3{L} : \forall int t, integer u, integer i; - @ i < 0 ==> cpt_le_u{L}(t, u, 0, i) == 0; - @ } - @/ - -//@ ensures \result == cpt_le_u{Here}(t, M, 0, 9); -int cpt (int t, int M) -{ - int s = 0; - -/@ loop invariant 0 <= i && i <= 10; - loop invariant I2: s == cpt_le_u{Here}(t, M, 0, i-1); - loop assigns i, s; -/ - for (int i = 0; i < 10; i++) { - if (t[i] <= M) - s++; - } - return s; -} -//------------------------------------------------------------------------------ -/@ axiomatic Le { - @ logic boolean le_G{L} (int x) reads G; - @ } -/ - -void logic_with_reads (int x) { - G = 0; - //@ assert ko: le_G{Here}(x) == le_G{Pre}(x); -} - - -//------------------------------------------------------------------------------ -int main (void) { return 0 ; } -//------------------------------------------------------------------------------ diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_guard_m1.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_guard_m1.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_guard_m1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_guard_m1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ - -int X, Y; -int T[10]; -int * P; - -struct Tstr { int a; int * p; } S; - -// notice that no guard is generated because there are only direct assigns, -// and direct access in the predicate. So M1 <==> M0. -//@ ensures X + Y + S.a + T[0] == \old(X + Y + S.a + T[0]) + 4; -void vars (void) { - X ++; - S.a ++; - T[0] ++; - Y ++; -} - -// This one cannot be proved because we don't know if P points on X -/@ ensures P > X; / -void f_no_hyp (void) { - int x = X; - P = x + 1; -} -/@ requires \separated (P, &X) && \separated (P, &P); - ensures P > X; -/ -void f_with_hyp (void) { - int x = X; - P = x + 1; -} -//@ ensures \result == 0; -int ptr_tab () { - P = &X; - T[2] = 0; - P = 3; - return T[2]; -} -// Rem : even if the postcondition is about the case where P points on X, -// we cannot prove it with M1 because the guard has to be verified in all cases. -//@ ensures c != 0 ==> \result == 0; -int ptr_tab_2 (int c) { - if (c) - P = &X; - T[2] = 0; - P = 3; - return T[2]; -} -/@ requires \valid(P); - ensures P == \old(P) + 1 && \result == 3; -/ -int locvar_globptr (void) { - int x = 3; - (P)++; - return x; -} -/ TODO : there is a problem here with M1 because (p) in ensure is ((\old(p)) - * and then p is an alias of old_p --> assign (p)++ is not ok ! / -/@ requires \valid(p); - ensures p == \old(p) + 1 && \result == 3; - / -int locvar_vs_paramptr (int * p) { - int x = 3; - (p)++; - return x; -} -void cmp_shift (int p, int i, int j) { - (p+i) = 1; - (p+j) = 2; - //@ assert i != j ==> (p+i) == 1; -} -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_if1.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_if1.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_if1.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_if1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -int c; - -//@ ensures ( (!(c==0)) ==> \result == 1) && ((c==0) ==> \result == 2); -int main(void) { - int x; - x = x; - if (c) x = 1; else x = 2; - return x; -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_inv_in_loop.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_inv_in_loop.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_inv_in_loop.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_inv_in_loop.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -/ run.config_phoare - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -// cf aussi bts494 examples in wp_loop.c - -//@ensures \result == 5; -int simple_inv (void) { - int i = 0; - while (i < 5) { - //@ invariant 0 <= i < 5 ; - i++; - } - return i; -} -int inv_from_init (void) { - int x = 5; - int i = 0; - //@ loop assigns i ; - while (i < 5) { - //@ invariant i < x ; - i++; - } - return i; -} -/ -int caveat_inv (int n) { - int i, s = 0; - //@ loop assigns i, s; - for (i = 0; i < n; i++) { - //@ invariant 0 <= i < n ; - s++; - } - return s; -} -/ -int double_loop (void) { - for (int i = 0; i < 10; i++) { - //@ invariant 0 <= i < 10 ; - //@ loop assigns j; - for (int j = 0; j < i; j++) { - //@ invariant 0 <= j 0 <= j < 20 ==> T[i][j] == 0; -/ -void razT2 (void) { - for (int i = 0; i < 10; i++) { - /@ invariant Ii: \forall int i0, j; 0 <= i0 0 <= j < 20 - ==>T[i0][j] == 0; - / - //@ loop assigns j, T[i][0..19]; - for (int j = 0; j < 20; j++) { - /@ invariant \forall int i0, j0; 0 <= i0 0 <= j0 < 20 - ==> T[i0][j0] == 0; / - /@ invariant \forall int j0; 0 <= j0 < j ==> T[i][j0] == 0; / - T[i][j] = 0; - } - } -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_ll2.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_ll2.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_ll2.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_ll2.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -/ run.config_pruntime - OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-proof z3 -wp-print -wp-verbose 2 -/ - -/ ---------------------------------------------------------------------------/ - -#define INT2DOUBLE(E,S) \ -{\ - register int i1;\ - register double f1;\ - i1=(E);\ - i1=(i1<<3)>>15;\ - f1=(double)i1;\ - (S)=f1;\ -} - -/@ logic integer read_bit(integer x, integer i) = - ((x & (1<<(i-1))) == 0) ? 0 : 1; / - -/@ -behavior x_29_13_positive : - assumes read_bit(x,29) == 0; - ensures \result == \sum(1, 16, - \lambda integer k; read_bit(x,12+k) * (1<<(k-1))); - -behavior x_29_13_negative : - assumes read_bit(x,29) == 1; - ensures \result == 1 + \sum(1, 16, - \lambda integer k; (1-read_bit(x,12+k)) * (1<<(k-1))); -/ -double INT2DOUBLE_wrapper(unsigned int x) { - double y; - INT2DOUBLE(x,y) - return y; -} - -/ ---------------------------------------------------------------------------/ - - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_ll.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_ll.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_ll.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_ll.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,254 +0,0 @@ -/ run.config_pruntime - OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-proof simplify -wp-print -wp-verbose 2 -/ - - -/ ---------------------------------------------------------------------------/ -/ TODO: many funny examples at - * http://graphics.stanford.edu/~seander/bithacks.html. - / -/ ---------------------------------------------------------------------------/ -int X,Y; -char T[10]; - -struct str { char c; int i; }; -struct str1 { int a; int b; int c; int d; } S1; -struct str2 { int x; int y; int z; } S2; - -/ ---------------------------------------------------------------------------/ - -#define NULL ((void)0) - - -//@ ensures \result == 0; -int null_is_zero (void) { - void * p = NULL; - return (int) p; -} - -//@ ensures c == 0 ==> \result == \null; -int * null (int c) { - int * p = c ? &X : NULL; - return p; -} -/* ---------------------------------------------------------------------------/ - -/ For numeric address as pointeur, see [tests/wp/numeric_addr.c] / - -/@ behavior bigendian : ensures \result == 1; - / -char ch_interp (void) { - int x = 0x01020304; - char p = &x; - char c = p; - return c; -} -/ -Lemma wp_ch_interp_bigendian_post_1 : - -intros M2 M3 M4 M5. -subst M5. -rewrite bits_of_sint8_of_bits. -subst M4. -repeat rewrite load_store_same. -rewrite uint32_of_bits_of_uint32. -subst M3. -rewrite load_store_disj; - [ | apply base_sep; rewrite x_0_name; rewrite p_0_name; - rewrite uniq_name; auto with zarith ]. -rewrite load_store_incl_part; unfold rt_incl; auto with zarith. -rewrite Zminus_diag. - -Remains : - sint8_of_bits (bits_part (bits_of_sint32 16909060) 0 8) = 1 -/ - -//@ assigns T[1..3]; -void range (void) { - T[1] = 1; - T[2] = 2; - T[3] = 3; -} - -/@ behavior bigendian : ensures \result == 3; - / -int cast4 (void) { - int p = T; - T[0] = 0; T[1] = 0; T[2] = 0; T[3] = 3; - return p; -} -/ - - -intros. -subst __retres mb3 mb2 mb1 mb0 p. -rewrite addr_of_pointer_of_addr. -unfold rt_shift. -repeat (rewrite simpl_as_int; [ | rewrite is_in_format_sint8; omega]). - -replace (rt_vaddr ma X_T + 0) with (rt_vaddr ma X_T) by omega. - -Hint Rewrite bits_concat_size rt_to_bits_size sint8_format_size : smp_rt_size. - -erewrite (store_concat mb); eauto. -3: erewrite (store_concat mb); eauto. -4: erewrite (store_concat mb); eauto. - -4: autorewrite with smp_rt_size; auto with zarith. -3: autorewrite with smp_rt_size; auto with zarith. -2: autorewrite with smp_rt_size; auto with zarith. - -rewrite load_store_same; autorewrite with smp_rt_size; auto with zarith. - -rewrite rt_int_from_bits. -rewrite big_b32_to_bbits; - [ |autorewrite with smp_rt_size; omega | ]. - -rewrite bits_concat_nth_byte_left; [ | autorewrite with smp_rt_size; omega]. -rewrite bits_concat_nth_byte_left; [ | autorewrite with smp_rt_size; omega]. -rewrite bits_concat_nth_byte_left; [ | autorewrite with smp_rt_size; omega]. - -rewrite bits_concat_nth_byte_left; [ | autorewrite with smp_rt_size; omega]. -rewrite bits_concat_nth_byte_left; [ | autorewrite with smp_rt_size; omega]. -erewrite (bits_concat_nth_byte_right _ _ 1); eauto; autorewrite with smp_rt_size; try omega. - -rewrite bits_concat_nth_byte_left; [ | autorewrite with smp_rt_size; omega]. -erewrite (bits_concat_nth_byte_right _ _ 2); eauto; autorewrite with smp_rt_size; try omega. - -erewrite (bits_concat_nth_byte_right _ _ 3); eauto; autorewrite with smp_rt_size; try omega. - -repeat rewrite nth_byte_0; autorewrite with smp_rt_size; auto. - -unfold cint_of_bits. -rewrite sint32_format_sign. -rewrite ite_true. -rewrite sint32_format_size. -rewrite sint_of_bits_def; [ | omega]. -repeat (rewrite concat_bytes_left; [ | omega]). -rewrite mbyte_to_bbits_def; autorewrite with smp_rt_size; try omega. -erewrite rt_to_bits_zero; eauto; autorewrite with smp_rt_size; try omega. -rewrite bit_of_bool_false; ring_simplify. - ---------------------- -Another one : - - - - -/ - -/ ---------------------------------------------------------------------------/ - -/@ requires \valid (p1); - ensures p1->b == 0; -/ -void struct_cast (struct str1 p1) { - struct str2 * p2 = (struct str2 ) p1; - //@ assert \valid (p2); - p2->y = 0; -} -//@ requires \valid (p2); -void invalid_struct_cast (struct str2 p2) { - struct str1 * p1 = (struct str1 ) p2; - //@ assert ko : \valid(p1); -} - -/ === About memcpy ----------------------------------------------------------/ - -/@ - requires \valid (src + (0..n-1)); - requires \valid (dest+(0..n-1)); - requires \separated (src + (0..n-1), dest+(0..n-1)); - - ensures \forall integer i; 0 <= i < n ==> dest[i] == \old(src[i]); - assigns dest[0..n-1] \from src[0..n-1] ; -/ -void memcpy(char dest, char src, unsigned long n); - -void use_memcpy_on_int (int p) { - int x; - memcpy (&x, p, sizeof (x)); - //@ assert x == \at(p,Pre); -} -/ -Proof. - -intros. -apply same_bits_same_val. -subst mb_3. -unfold rt_shift in ; simpl; rewrite Zplus_0_r. -unfold rt_vzone. -erewrite rt_valloc_size; [ | subst ma0; eauto]. -rewrite load_store_same. - - -( 1st byte 8 ) -eapply (eq_bits_split _ _ 32 _ _ 8 24); auto with zarith. - -eapply same_int_val_same_bits in H1; - try instantiate (1 := 0); - try rewrite sint8_format_size; - try rewrite bits_part_size; - try rewrite rt_load_size; - try rewrite size_zone; - auto with zarith. - -rewrite load_store_incl_part in H1; [ | - unfold rt_incl; repeat rewrite addr_zone; repeat rewrite size_zone; auto with zarith]. -repeat rewrite addr_zone in H1; rewrite size_zone in H1. -unfold rt_shift in . - simpl in H1; repeat rewrite Zplus_0_r in H1; - rewrite Zminus_diag in H1. - -rewrite H1. -eapply bits_part_rt_load; eauto; [ | - unfold rt_incl; repeat rewrite addr_zone; repeat rewrite size_zone; auto with zarith]. -rewrite addr_zone; rewrite Zplus_0_r; auto. - -auto with zarith. - -(* Same thing for 2d 3rd 4th byte ... ) - -eapply (eq_bits_split _ _ 24 _ _ 8 16); auto with zarith; - repeat rewrite bits_part_of_bits_part; simpl. - -Save. - - / - -void use_memcpy_on_struct (struct str * p) { - struct str x; - memcpy (&x, p, sizeof (x)); - //@ assert x == \at(p, Pre); -} -/ - -intros. - -rewrite EqrecDef_str. -split; erewrite <- bits_part_vs_access; eauto; - [ rewrite Loaded_str_c; - destruct Finfo_str_c as [Hf1 [Hf2 Hf3]]; - rewrite Hf1; rewrite Hf2; rewrite Hf3 - | rewrite Loaded_str_i; - destruct Finfo_str_i as [Hf1 [Hf2 Hf3]]; - rewrite Hf1; rewrite Hf2; rewrite Hf3 -]; clear Hf1 Hf2 Hf3 . - -(* 1st field is a [char] ) - -replace 0 with (80) by auto with zarith . -rewrite <- (H2 0); auto with zarith; clear H2. -apply same_bits_same_val. -symmetry. eapply bits_part_rt_load; eauto; - unfold rt_vzone, rt_incl, rt_shift; - repeat rewrite addr_zone; repeat rewrite size_zone; split; auto with zarith. - -erewrite rt_valloc_size; subst ma0; eauto; auto with zarith. - -(* 2d field ) - -see. use_memcpy_on_int - - / -/* ---------------------------------------------------------------------------/ diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_localaddr.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_localaddr.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_localaddr.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_localaddr.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -/ run.config_pruntime - OPT: -wp -wp-model Runtime -wp-no-logicvar -journal-disable -wp-proof simplify -wp-print -wp-verbose 2 -/ - -//@ensures \result ; -int f(void) -{ - int p; - int q; - - { int x=1 ; p = &x ; } - { int y=2 ; q = &y ; } - - //@assert p_invalid_ok: !\valid(p) ; - //@assert q_invalid_ok: !\valid(q) ; - //@assert p_q_compare_ko: p != q ; - //@assert p_q_compare_ok: \valid(p) ==> \valid(q) ==> p!=q ; - - //@assert p_read_ko: p == 1 ; - //@assert q_read_ko: q == 2 ; - - return p == 1 && q == 2 ; - -} - -/@ ensures ok : \result == 0 || \result == 1; - ensures ko1 : \result == 0; - ensures ko2 : \result == 1; -/ -int cmp_invalid_addr (void) { - int p; - int q; - - { int x=1 ; p = &x ; } - { int y=2 ; q = &y ; } - - return (p == q) ? 1 : 0; -} - -/@ ensures ok : \result == 0 || \result == 1; - ensures ko1 : \result == 0; - ensures ko2 : \result == 1; -/ -int cmp_invalid_addr_as_int (void) { - int p; - int q; - - { int x=1 ; p = (int) &x ; } - { int y=2 ; q = (int) &y ; } - - return (p == q) ? 1 : 0; -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_loop.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_loop.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_loop.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_loop.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,399 +0,0 @@ - -/ run.config_phoare - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -//@ assigns \nothing; -void infinite (int c) { - int s = 0; - if (c) { - //@ loop assigns s; - while (1) - s++; - //@ assert 2 > 1; - } - //@ assert c == 0; -} - -//@ assigns \nothing; -void loops (int c) { - int x; - - if (c) x=0; - x=3; - - - //@ loop assigns x; - while (c) { x=0;} - x=1; - - - if (c) - //@ loop assigns x; - while(c) x=0; - x=1; - - - if (c) - //@ loop assigns x; - do {x=0; } while(c); - x=1; - //@ assert x == 1; - -} - -/@ assigns \nothing; - ensures \result == 9 ; / -int classical_loop () { - int i; - int s = -1; - - /@ loop invariant s + 1 == i && i <= 10; - @ loop assigns i, s; - / - for (i=0; i< 10; i++) s = i ; - - return s; -} - -/@ assigns \nothing; - ensures \result == 5; / -int simple_loop (int c) { - int x; - int c = 0; - - /@ loop invariant 0 <= c <= 6 && ((c==0 || x == c-1)); - @ loop assigns c, x; - / - for(c=0;c<=5;) { - // CEA_DUMP(); - x = c; - c++; - // CEA_DUMP(); - } -// CEA_DUMP(); -//@ assert c == 6; - return x; -} - -/@ assigns \nothing; - ensures \result == 6; / -int goto_natural_loop (int c) { - int c = 0; -L : if (c > 5) goto R; - c++; - goto L; -R : return c; -} - -int T[10]; - -//@ ensures \result == T + 5; -int ptr_on_array () { - int * p = T; - int i; - /@ loop invariant i <= 5 && p == T+i; - @ loop assigns i, p; - / - for (i = 0; i < 5; i++) - p++; - return p; -} - -void assigns_loop_tab (void) { - //@ loop assigns i, T[0..i-1]; - for (int i = 0; i < 10; i++) { - T[i] = 0; - } -} -//@ requires \valid (&(t[0..9])); -void assigns_loop_ptr (int * t) { - /@ loop assigns i, t[0..i-1]; - loop invariant (10 >= i >= 0); - / - for (int i = 0; i < 10; i++) { - t[i] = 0; - } -} - -/@ ensures p_ok : T[9] == \old(T[9]); - ensures p_ko : T[3] == \old(T[3]); -/ -void post_using_loop_assigns (void) { - /@ loop invariant i <= 7; - loop assigns i, T[0..i-1]; - / - for (int i = 0; i < 7; i++) { - T[i] = 0; - } -} - -/@ ensures p_ok : T[9] == \old(T[9]); - ensures p_ko : T[3] == \old(T[3]); -/ -void post_using_loop_assigns_no_inv (void) { - /@ loop assigns i, T[0..6]; / - for (int i = 0; i < 7; i++) { - T[i] = 0; - } -} - - -void loop_assert () { - int i = 0; - /@ loop invariant i >= 0; - @ loop assigns i; / - while (i < 10) { - ++i; - //@ assert 0 < i <= 10; - } -} - -int loop_assigns () { - int i = 0; - int s = 0; - /@ loop assigns i, s; - / - while (i < 10) { - s += i; - i++; - } - return s; -} -int loop_assigns_ko (void) { - int s = 0; - int i; - //@ loop assigns s; - for (i = 0; i < 10; i++) { - s++; - } - return s; -} - -int loop_var (int n) { - int i, s = 0; - /@ loop assigns i, s; - @ loop variant (n - i); - / - for (i = 0; i < n; i++) { - s++; - } - return s; -} - -int loop_inv_only (int n) { - int i, s = 0; - /@ loop invariant 0 <= i && s == i; - loop assigns i,s ; / - for (i = 0; i < n; i++) { - s++; - } - return s; -} - -//@ ensures \result == -1 || T[\result] == a; -int find (int a) { - int i; - //@ loop assigns i; - for (i = 0; i < 10; i++) { - if (T[i] == a) return i; - } - return -1; -} -int inv_need_init () { - int k = 4; - int i = 0; - /@ loop invariant i <= 4; - loop assigns i; - / - while (i < k) - i++; - return i; -} - -/@ requires 0 <= m && m < M && M <= 10; - @ ensures \forall int k; m <= k && k < M ==> T[k] == 0; -/ -void raz (int m, int M) { - /@ loop invariant m <= i && i <= M; - loop invariant \forall int k; m <= k && k T[k] == 0; - loop assigns i, T[m..(i-1)]; - / - for (int i = m; i < M; i++) { - T[i] = 0; - } -} -void loop_assigns_limit (void) { - /@ loop invariant T[i] == \at(T, Pre)[i]; - loop invariant 0 <= i; - loop assigns i, T[0..(i-1)]; - / - for (int i = 0; i < 10; i++) - T[i] = 0; -} -/----------------------------------------------------------------------------/ - -//@ ensures \result >= n; -int bts494a (int n) { - int i = 0 ; - //@ loop invariant 0 <= i && (0 <= n ==> i <= n) && n == \at(n, Pre); - while (i < n) - i++ ; - return i; -} - -//@ ensures \result >= n; -int bts494b (int n) { - int i = 0 ; - /@ loop invariant 0 <= i && (0 <= n ==> i <= n); - loop assigns i; - / - while (i < n) - i++ ; - return i; -} - -//@ ensures \result >= n; -int bts494c (int n) { - int i = 0 ; - while (i < n) - //@ invariant 0 <= i < n && n == \at(n, Pre); - i++ ; - return i; -} - -/----------------------------------------------------------------------------/ -/----------------------------------------------------------------------------/ -/* Examples from DivEx1.c but adapted to substitute pointer by array - * to be able to test is with Hoare. / - -typedef struct {int ch11[10]; int ch12;} T1; -typedef struct {int ch21; T1 ch22;} T2; - -T2 t[20]; - -void loops_simple_assigns (void) { - int i, j ; - - /@ loop assigns i, j, t[0..19].ch21, t[0..19].ch22.ch11[..]; - loop invariant I0: oracle_ok: 0 <= i && i <= 20; - loop invariant I1 : oracle_ok: - \forall int k; 0 <= k && k t[k].ch21 == 0; - / - for (i = 0 ; i < 20 ; i++) { - t[i].ch21 = 0 ; - /@ loop assigns j, t[i].ch22.ch11[0..9]; - loop invariant J0: oracle_ok: 0 <= j && j <= 10; - / - for (j = 0 ; j < 10 ; j++) - t[i].ch22.ch11[j] = 0 ; - } -} - -void loops_var_assigns (void) { - int i, j ; - - /@ loop assigns i, j, t[0..i-1].ch21, t[0..i-1].ch22.ch11[..]; - loop invariant I0: oracle_ok: 0 <= i && i <= 20; - loop invariant I1 : oracle_ok: - \forall int k; 0 <= k && k t[k].ch21 == 0; - / - for (i = 0 ; i < 20 ; i++) { - t[i].ch21 = 0 ; - /@ loop assigns j, t[i].ch22.ch11[0..j-1]; - loop invariant J0: oracle_ok: 0 <= j && j <= 10; - / - for (j = 0 ; j < 10 ; j++) - t[i].ch22.ch11[j] = 0 ; - } -} - -/----------------------------------------------------------------------------/ -/ This is the example of loop variant given in ACSL document. - * Notive that this loop variant is ok even for \at(Pre, x < 0). - * Notice also that the variant can be negative at the last iteration. / -void doc_acsl_variant (int x) { - //@ loop variant x; - while (x >= 0) { - x -= 2; - } -} -/----------------------------------------------------------------------------/ -/ The ensures of [incr_tab] is proved, - * and it should be proved in [incr_tab] too, - * but it seems that we don't manage to use the loop assigns... / - -//@ ensures \forall integer k; 0 <= k < 10 ==> T[k] == \old(T[k]) + 1; -void incr_tab (void) { - int x = 1; - /@ loop invariant @ 0 <= i <= 10 - @ && (\forall integer k; 0 <= k T[k] == \at(T[k],Pre) + x) - @ && x == 1 - @ && (\forall integer k; i <= k ==> T[k] == \at(T[k],Pre)) - @ ; - / - for (int i = 0; i < 10; i++) { - T[i] = T[i] + x; - } -} - -//@ ensures \forall integer k; 0 <= k < 10 ==> T[k] == \old(T[k]) + 1; -void incr_tab_assigns (void) { - int x = 1; - /@ loop invariant @ 0 <= i <= 10 - @ && (\forall integer k; 0 <= k T[k] == \at(T[k],Pre) + x) - // @ && x == 1 - // @ && (\forall integer k; i <= k ==> T[k] == \at(T[k],Pre)) - @ ; - @ loop assigns i, T[0..i-1]; - / - for (int i = 0; i < 10; i++) { - T[i] = T[i] + x; - } -} - -/@ requires \valid(t) - && \forall integer k; 0 <= k < 10 ==> \separated (&t, t+k); - @ ensures \forall integer k; 0 <= k < 10 ==> t[k] == \old(t[k]) + 1; -/ -void incr_ptab (int t) { - int x = 1; - /@ loop invariant @ 0 <= i <= 10 - @ && (\forall integer k; 0 <= k t[k] == \at(t[k],Pre) + x) - @ && t == \at(t, Pre) - @ && \forall integer k; 0 <= k < 10 ==> \separated (&t, t+k) - @ && x == 1 - @ && (\forall integer k; i <= k ==> t[k] == \at(t[k],Pre)) - @ ; - / - for (int i = 0; i < 10; i++) { - t[i] = t[i] + x; - } -} - -/@ requires \valid(t); - @ ensures \forall integer k; 0 <= k < 10 ==> t[k] == \old(t[k]) + 1; -/ -void incr_ptab_assigns (int * t) { - int x = 1; - /@ loop invariant @ 0 <= i <= 10 - @ && (\forall integer k; 0 <= k t[k] == \at(t[k],Pre) + x) - // @ && x == 1 - // @ && (\forall integer k; i <= k ==> t[k] == \at(t[k],Pre)) - @ ; - @ loop assigns i, t[0..i-1]; - / - for (int i = 0; i < 10; i++) { - t[i] = t[i] + x; - } -} -/----------------------------------------------------------------------------/ -//@ requires \valid (&t[0..n-1]); -void valid_range_inv (int t, int n) { - //@ loop invariant n == \at(n,Pre); - for (int i = 0; i < n; i++) { - //@ assert \valid (t+i); - t[i] = 0; - } -} -/----------------------------------------------------------------------------/ diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_niy.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_niy.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_niy.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_niy.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -/@ - requires n >= 0; - terminates \true; - decreases 101 - n; - assigns \nothing; - behavior b91 : - assumes n <= 101; - ensures \result == 91; - behavior b100 : - assumes n > 100; - ensures \result == n - 10; -/ -int f91 (int n) { - if ( n > 100 ) - return n - 10; - else - return f91(f91(n+11)); -} - -// This is not handled yet, -// but I am not sure that we should accept to take the address of \result... -//@ ensures \valid (&(\result)); -int addr_result (void) { - return 0; -} - -int loop2 (int n) { - int i, s = 0; - for (i = 0; i < n; i++) { - //@ invariant 0 <= i < n ; - s++; - } - return s; -} - -/@ requires c > 0; - / -int goto_loop (int c) { - int x = 1; - L : x++; - //@ invariant (0 < c <= \at(c, Pre)) && x == 2 + (\at(c, Pre) - c); - if (--c > 0) goto L; - return x; -} - -/ Doc example 2.45 / -int abrupt (int x) { - while (x > 0) { - /@ breaks x % 11 == 0 && x == \old (x ); - @ continues (x +1) % 11 != 0 && x % 7 == 0 && x == \old (x ) -1; - @ returns ( \result +2) % 11 != 0 && ( \result +1) % 7 != 0 - @ && \result % 5 == 0 && \result == \old (x ) -2; - @ ensures (x +3) % 11 != 0 && ( x +2) % 7 != 0 && (x +1) % 5 != 0 - @ && x == \old (x ) -3; - @ / - { - if (x % 11 == 0) break ; - x--; - if (x % 7 == 0) continue ; - x--; - if (x % 5 == 0) return x; - x--; - } - } - return x; -} - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_object.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_object.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_object.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_object.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ - -typedef struct S { - int f ; - int t[10] ; -} ; - -struct S s; -int a[10] ; - -//@ensures (s) == { \old(s) \with .t = a } ; -void f(struct S s) -{ - /@loop assigns i,s->t[0..(i-1)] ; - @loop invariant 0 <= i <= 10 ; - @loop invariant \forall int k ; 0<=k s->t[k] == a[k] ; - @/ - for (int i=0; i<10; i++) - s->t[i] = a[i] ; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_old_at.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_old_at.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_old_at.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_old_at.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ - -int G, X, T[10]; - -// Notice that \result is in fact a shortcut for \at(\result, Post) -/@ ensures \old(\result - (X + 1)) == 0 ; // test of frama-c comment -/ -int test_at_old (int i) { - X++; -L : i++; - T[X] ++ ; - //@ assert i > \at(i, L) && \at(i, Here) == \at(i, Pre) + 1; - // Invalid assert Old is forbiden in 'assert' - // @ assert i > \at(i, Old); - return X; -} - -// this one seem problematic, but it is not because we push downward -// the \at to the data. -void at_imbric_ok (int a, int b) { - a = 0; -La : a = 1; - b = 0; -Lb : b = 1; - //@ assert \at(a + \at(b, Lb), La) == 0; - // Notice that La and Lb have to be in that order to see the problem, - // because if La appears before in WP computation, it then makes Lb visible - // without need of special processing. -} - -void at_imbric_ko (int a, int b) { - a = 0; - T[a] = 0; -La : a = 1; - b = 0; -Lb : b = 1; - //@ assert \at(T[ \at(b, Lb)], La) == 0; -} - -// label are normalized by cil -> Lb disapear. -void at_same_point (int a, int b) { - a = 0; - b = 0; - T[b] = 0; -La : -Lb : a = 1; - b = 1; - //@ assert \at(T[ \at(b, Lb)], La) == 0; -} - - -//@ ensures \old(T[\at(X,Here)] + 1) == \at(T[X], Post) ; -void test_at_imbric (void) { - X++; - T[X] ++; -} - -void labels_in_index (int a, int b) { -La : a = a+ 1; - b = 0; -Lb : b = 1; - T[a-1] = 0; -Lt : T[a-1] = 1; - //@ assert \at(T[\at(a + \at(b, Lb), Pre)], Lt) == 0; -} - - -//@ ensures \result[\at(i, Pre)] == 0; -int * result_and_pre (int i) { - int * p0, * pi; - p0 = T; - pi = p0 + i; - i = 0; - pi = i; - return p0; -} - -// result_and_pre contient no_itself_pointer : -// manque hypothèse qu'un pointeur ne peut pointé -// sur lui-même en l'absence de cast. - -int p; -int i; -/@ assigns p; - ensures p==\old(p); / -void no_itself_pointer(){p=0;} - -void labels_in_stmt_annot (void) { - X ++; - /@ requires X > \at(X, Pre); - behavior B: - ensures X == \old(X) + 1; - ensures X == \at(X,Pre) + 2; - ensures X == \at(X,Post); - / - X++; - X++; - //@ assert X == \at(X,Pre) + 3; -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_pointer.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_pointer.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_pointer.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_pointer.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ - -/@ requires \valid(p+1) ; - ensures (p+1) == 56 ; / -int main(int p) { - int x = 55; - (p+1) = x + 1 ; - //@ assert 56 == (p+1) ; - x++; - return 0; -} - -int G; -/@ behavior b1 : - @ ensures \old(G) >=0 ==> G == \old(G); - @ behavior b2 : // this one seems similar to b1 - @ assumes G >= 0; - @ ensures G == \old(G); -/ -void f () { - int * p; - p = &G; - if (G < 0) - p = 0; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_pre_bhv.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_pre_bhv.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_pre_bhv.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_pre_bhv.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -/ run.config - OPT: -wp -wp-model Hoare -wp-print - / - -// ORACLES FAUX pour les preuves des preconditions de main. -// On attend le but Start => A => U -// On obtient les buts Start, A et U - -//@ predicate P(integer x) ; - -int x = 0; - -/@ requires Start: P(x) ; - @ ensures Final: P(x+1) ; - @ behavior useless: - @ assumes A: P(x+2) ; - @ requires U: P(x+3) ; - @ ensures B: P(x+4) ; - @ / -int main(void) { - -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_pre.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_pre.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_pre.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_pre.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -/ run.config - OPT: -wp -wp-model Hoare -wp-print - - run.config_phoare - OPT: -journal-disable -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -//------------------------------------------------------------------------------ -// This file is to test the preconditions verification -//------------------------------------------------------------------------------ - -int X; // even if not initialized, we should be able to check that it is 0. -int X2 = 2; -int T[10]; - -//@ requires X >= 0; ensures X > 0; -void f (void) { - X++; -} - -/@ requires X2 == 2; - @ requires X == 0; - @ requires \valid (&X); - @ requires \valid (&(T[0..9])); -/ -int main (void) { - f (); - return 0; -} - -//------------------------------------------------------------------------------ diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_range.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_range.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_range.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_range.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -/ run.config_phoare - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -// le tout passe avec z3 -// frama-c-gui -wp-mm 2 -wp-prover z3 wp_range.c & - - -int T[10]; - -/@ requires 0 <= i < 10; - @ ensures T[i] == \old(T[i]) + 1; - / -void incr_elem_tab (int i) { - T[i]++; -} - -/@ requires \valid_range(p,0,i) ; - ensures (\old(p)+i) == 78; -/ -void main (int p,int i) { - p++; - p++; - p++; - (p+i-3) = 78; -} - -/@ requires 0 <= i < 5; - @ ensures \result == i; - / -int local_tab (int i) { - int t[5]; - //@ assert \valid (t+i); - t[i] = i; - return t[i]; -} - -int * P; - -//@ ensures \forall int j; n <= j ==> (P + j) == \old((P + j)); -int loop_assign (int n) { - int i; - //@ loop assigns i, P[0..(n-1)]; - for (i = 0; i < n; P++, i++) - P = 0; - return i; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_rte.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_rte.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_rte.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_rte.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -/ run.config_phoare - OPT: -journal-disable -rte -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 - / - -int T[10]; - -int read5 (void) { - return T[5]; -} - -/@ requires 0 <= i < 10; - / -int read (int i) { - return T[i]; -} - -int local_array (void) { - int t [8]; - return t[5]; -} - -int fext (); - -//@ ensures T[0] == \old(T[0]); -int call_fext () { if (fnd()) return 1; else return 0; } - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_show.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_show.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_show.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_show.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ - -/ ~~~ First of all, let's launch the tool : - cd ~/frama-c; FRAMAC_SHARE=share bin/viewer.opt tests/wp/wp_show.c - / - -/ ~ Let's start with model 0 (no matter wp_bottom) / - -/@ - requires min <= max; - ensures min <= \result <= max; - - behavior Cmin : assumes x < min; ensures \result == min; - behavior Cmax : assumes x > max; ensures \result == max; - behavior Cx : assumes min <= x <= max; ensures \result == x; - - complete behaviors Cmin, Cmax, Cx; - disjoint behaviors Cmin, Cmax, Cx; - / -int threshold (int min, int max, int x) { - if (max < x) - x = max; - if (x < min) - x = min; - return x; -} - -/ ~ M0 also works with arrays, structures and union / - -int T [10]; -typedef struct _Tstr { char a; int t[50]; float x; char p; } Tstr; -Tstr S; - -//@ ensures 0 <= j && j < 10 && i != j ==> \result == \old(T[j]); -int fstruct (int i, int j) { - int j2 = (0 <= j && j < 10) ? j : 0; - if (0 <= i && i < 10) - T[i] = S.t[i]; - return T[j2]; -} - -/* ~ loops are handled / - -//@ ensures \forall int i; 0 <= i < 10 ==> T[i] == 0; -void razT (void) { - int i; - //@ loop invariant \forall int k; 0<= k T[k] == 0; - for (i = 0; i < 10; i++) - T[i] = 0; -} - -/ ~ if one wants to use a light invariant, [loop assigns] should be used. / - -void stat (int n) { - int i_min = 0, i_max = 0; - int min = S.t[0], max = S.t[0]; - int i, s = 0; - /@ loop invariant \forall int k; 0<= k min <= S.t[k]; - loop assigns S; - / - for (i = 1; i < n; i++) { - s += S.t[i]; - if (S.t[i] < min) { min = S.t[i]; i_min = i; } - if (S.t[i] > max) { max = S.t[i]; i_max = i; } - } -} - -/ ~ calls are handled, but [assigns] specification is needed / - - -/ ~ M0 can also deal with pointer computation, as long there is no access / - -/@ behavior B0: ensures \result == &(T[i]) || \result == &(S.t[i]); - behavior B1: ensures \result >= T[i]; - / -int * fptr (int i) { - int * p = (T[i] > S.t[i]) ? T : S.t; - return p + i; -} - -/* ~ let's now test [wp_bottom] option : / - -/ ~ with bottom we can prove this property / - -//@ behavior xpos : assumes x > 0; ensures \result == 1; -int fbot (int x) { - if (x > 0) - x = 1; - else { - x = (S.p); - (S.p) = 0; - } - return x; -} - -/ ~~~ we can prove some properties with a simple model, and then use them - * as hypotheses to prove some others. / - -int main (void) { return 0 ; } diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_split.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_split.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_split.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_split.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -/ run.config - OPT: -wp -wp-model Hoare -wp-split -wp-print -wp-split-dim 2 -/ -int a, b, c, d, e; - -/@ - assigns \nothing; - - behavior split_and: - assumes a==0 && b==0 && c==0 && d==0 && e==0; - ensures ok:a==0 && b==0 && c==0 && d==0 && e==0; - - behavior split_if: - assumes (a==0 ==> b==0) && (a!=0 ==> c==0); - ensures ok:(a==0 ? b==0 : c==0) ; - - behavior split_forall: - assumes (\forall integer x ; (0<x<a ==> x<b)) && c==0; - ensures ok: \forall integer x ; (0<x<a ==> (x<b && c==0)) ; - - behavior split_not: - assumes !a==0; - ensures ok:!a==0; - - behavior split_not_not: - assumes a==0 && b==0; - ensures ok:!(!a==0 || !b==0); - - behavior split_not_or: - assumes !(a==0 || b==0); - ensures ok:!(a==0 || b==0); - - behavior split_not_if: - assumes (a==0 ==> b!=0) && (a!=0 ==> c!=0); - ensures ok:!(a==0 ? b==0 : c==0) ; - - behavior split_not_exists: - assumes (\forall integer x ; (0<x<a ==> x<b)) && c==0; - ensures ok: !\exists integer x ;(0<x<a && (!(x<b) || c!=0) ) ; - - / -void f(void) { - -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_strategy.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_strategy.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_strategy.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_strategy.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -/ run.config -OPT: -journal-disable -wp -wp-model Hoare -wp-print -wp-verbose 2 -OPT: -journal-disable -wp -wp-model Store -wp-print -wp-verbose 2 -wp-prop assigns -wp-assigns memory -/ -/ run.config_phoare -OPT: -journal-disable -rte -wp -wp-model Hoare -wp-print -wp-verbose 2 -wp-proof alt-ergo -/ - -/----------------------------------------------------------------------------/ - -/ This file is to test the strategy generation, so it doesn't need to be tested - * for different models. Let's choose examples that work with Hoare, - * except to test assign properties that need Store. - / - -/----------------------------------------------------------------------------/ -/ we shouldn't be able to prove ko1 from ko2 and then ko2 from ko1 / -/@ ensures ko1 : \result == x+1; - ensures ko2 : \result == x+1; -/ -int bts0513 (int x) { - return x; -} - -int bts0513_bis (int x) { - int i; - //@ assert ko1 : x > 0; - //@ assert ok : x > 0; - return x; -} -/----------------------------------------------------------------------------/ -// Problem of dependancies : we should be able to prove A, and the proof -// of E shouldn't depend on A ! - -void dpd1 (int x) { - //@ ensures Eko: x>0; - ; - //@ assert A: x>0; -} - -// workaround : -//@ behavior P: -void dpd2 (int x) { - //@ ensures Eko: x>0; - ; - //@ for P: assert A: x>0; -} -//============================================================================== -// specification of an IF block : notice that the proof of the ensures property -// shouldn't depend on [spec_if_f] properties. - -int Z; -int T[10]; - -/@ assigns T[i]; ensures T[i] > i; / -void spec_if_f (int i); - -//@ ensures T[0] > 0; -void spec_if (int c0, int c1, int c2) { - //@ assigns T[0], Z; ensures T[0] > 0; - if (c0) { spec_if_f (0); } else { T[0] = 5; } - //@ assigns T[1], Z; - if (c1) { spec_if_f (1); } else { Z++; } - //@ assigns T[2], Z; - if (c2) { spec_if_f (2); } else { Z++; } -} - -//============================================================================== -// when a IF condition is a negation, the AST doesn't have the same structure ! -// -void spec_if_cond (int c0) { - int i; - //@ ensures i > 0; - if (c0) { i = 2; } else { i = 1; } -} - -void spec_if_not_cond (int c0) { - int i; - //@ ensures i > 0; - if (!c0) { i = 2; } else { i = 1; } -} - -//============================================================================== -// Test is unnamed (default) behavior for function and blocks are not mixed -// together. - -//@ requires c == 0 ==> x >= 0; ensures \result > 0; -int default_behaviors (int c, int x) { - int y; - - //@ ensures stmt_p: x > 0; - if (c) x = 1; - else { - //@ assert x >= 0; - x++; - } - y = 0; - //@ assert x > y; - return x; -} -//============================================================================== diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_swap.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_swap.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_swap.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_swap.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ - -/ run.config_phoare - OPT: -journal-disable -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -int G; -void main(int a, int b) { - if (a > b) { int tmp = a; a = b; b = tmp; } - /@ assert a <= b; / -} - -void main1( int a, int b, int c, int d) { - int tmp; - - if (a > b) { tmp = a; a = b; b = tmp; } - if (c > d) { tmp = c; c = d; d = tmp; } - if (a > c) { tmp = a; a = c; c = tmp; } - if (b > d) { tmp = b; b = d; d = tmp; } - if (b > c) { tmp = b; b = c; c = tmp; } - /@ assert a <= b <= c <= d; / -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_switch.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_switch.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_switch.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_switch.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,184 +0,0 @@ - -/ run.config_phoare - OPT: -journal-disable -wp -wp-model Hoare -wp-proof alt-ergo -wp-print -wp-verbose 2 -/ - -/ - * To test [switch] in CFG : only need to test with one model. - * To view the graph : - FCT=simple; ./frama-c -wp -wp-dot -wp-fct $FCT tests/wp/wp_switch.c; \ - zgrviewer $FCT.cfg.dot - / - -/@ - behavior x1 : assumes x == 1; ensures \result == 2; - behavior x2 : assumes x == 2; ensures \result == 3; - behavior df : assumes x != 1 && x !=2; ensures \result == 11; - complete behaviors; disjoint behaviors; -/ - -int simple (int x) { - int res = 0; - switch (x) { - case 1: res = 1; break; - case 2: res = 2; break; - default : res = 10; - } - res = res+1; - return res; -} -/@ - behavior x1 : assumes x == 1; ensures \result == 2; - behavior x2 : assumes x == 2; ensures \result == 3; - behavior df : assumes x != 1 && x !=2; ensures \result == 1; - complete behaviors; disjoint behaviors; -/ - -int no_default (int x) { - int res = 0; - switch (x) { - case 1: res = 1; break; - case 2: res = 2; break; - } - res = res+1; - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 3; - behavior x2 : assumes x == 2; ensures \result == 2; - behavior df : assumes x != 1 && x !=2; ensures \result == 1; - complete behaviors; disjoint behaviors; -/ -int no_break (int x) { - int res = 0; - switch (x) { - case 1: res++; - case 2: res++; - } - res++; - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 1; - behavior x2_KO : assumes x == 2; ensures \result == 2; - behavior df : assumes x != 1 && x !=2; ensures \result == 0; - complete behaviors; disjoint behaviors; -/ -int same_case (int x) { - int res = 0; - switch (x) { - case 1: res=1; break; - case 2: res=2; break; - case 1+1: res=4; break; - } - return res; -} - -/@ - behavior x1 : assumes x == 1 || x == 2; ensures \result == 1; - behavior x2 : assumes x == 4; ensures \result == 4; - behavior df : assumes x != 1 && x !=2 && x != 4; ensures \result == 0; - complete behaviors; disjoint behaviors; -/ -int multi_case (int x) { - int res = 0; - switch (x) { - case 1: case 2: res=1; break; - case 4: res = 4; - } - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 1; - behavior df : assumes x != 1; ensures \result == 2; - complete behaviors; disjoint behaviors; -/ -int case_and_default (int x) { - int res = 0; - switch (x) { - case 1: res=1; break; - case 2: - default: res = 2; - } - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 1; - behavior df : assumes x != 1; ensures \result == 2; - complete behaviors; disjoint behaviors; -/ -int dead_inst (int x) { - int res = 0; - switch (x) { - case 1: res=1; break; - default: res = 2; break; - res = 3; - } - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 1; - behavior x2 : assumes x == 2; ensures \result == 0; - behavior df : assumes x != 1 && x !=2; ensures \result == 3; - complete behaviors; disjoint behaviors; -/ -int empty_case (int x) { - int res = 0; - switch (x) { - case 1: res=1; break; - case 2: break; - default: res=3; - } - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 1; - behavior df : assumes x != 1; ensures \result == 2; - complete behaviors; disjoint behaviors; -/ -int default_before (int x) { - int res = 0; - switch (x) { - default: res=2; break; - case 1: res=1; break; - } - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 1; - behavior df : assumes x != 1; ensures \result == 2; - complete behaviors; disjoint behaviors; -/ -int default_before_no_break (int x) { - int res = 0; - switch (x) { - default: res++; - case 1: res++; - } - return res; -} - -/@ - behavior x1 : assumes x == 1; ensures \result == 5; - behavior x2 : assumes x == 2; ensures \result == 1; - behavior x3 : assumes x == 3; ensures \result == 11; - behavior df : assumes x != 1 && x !=2 && x !=3; ensures \result == 0; - complete behaviors; disjoint behaviors; -/ -int another_label (int x) { - int res = 0; - switch (x) { - case 1: res=5; break; - case 2: L: res++; break; - case 3: res = 10; goto L; - } - return res; -} - diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_types.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_types.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_types.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_types.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -typedef enum _Color { Blue, Red, Black = 0 } Color; - -int int_of_color (Color col) { - int x; - if (col != Black) { - x = col; //@ assert x != 0; - } - else { - x = Black; //@ assert x == Blue; // strange property, isn't it? - } - return x; -} - - -//@ ensures \exists Color c; \result == c; // strange property, isn't it? -Color unspecified_color (void) { - return 10; // Unfortunatly, this is not forbidden! -} - -//@ ensures \result == Blue; -Color enum_in_annot (void) { - return Blue; -} diff -Nru frama-c-20110201+carbon+dfsg/tests/wp/wp_valid.c frama-c-20111001+nitrogen+dfsg/tests/wp/wp_valid.c --- frama-c-20110201+carbon+dfsg/tests/wp/wp_valid.c 2011-02-07 13:41:40.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/tests/wp/wp_valid.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -// see also : tests/wp/bts0085.c for a lot of tests about valid pointers - -int P; -int T[10]; - -//@ requires \valid(P); -void f (void) { - int x; //@ assert P != &x; -} - -// If we don't know that \valid(p), we sould not be able to proof this. -//@ ensures \result == \old(p); -int disj (int p) { - int x = 3; - return p; -} - -/@ ensures ok1: 0 <= i < 10 ==> \valid (\result); - ensures ko: i == 10 ==> \valid (\result); - / -int valid_in_global_array (int i) { - return T+i; -} diff -Nru frama-c-20110201+carbon+dfsg/VERSION frama-c-20111001+nitrogen+dfsg/VERSION --- frama-c-20110201+carbon+dfsg/VERSION 2011-02-07 13:45:55.000000000 +0000 +++ frama-c-20111001+nitrogen+dfsg/VERSION 2011-10-10 08:40:09.000000000 +0000 @@ -1 +1 @@ -Carbon-20110201 +Nitrogen-20111001